--  SPDX-License-Identifier: Apache-2.0
--
--  Copyright (c) 2016 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 Ada.Characters.Latin_1;
with Ada.Strings.Fixed;

with GL.Debug;

with Orka.Strings;
with Orka.Terminals;

package body Orka.Rendering.Programs.Modules is

   use GL.Debug;
   package Messages is new GL.Debug.Messages (Third_Party, Other);

   function Trim_Image (Value : Integer) return String is
     (Orka.Strings.Trim (Integer'Image (Value)));

   procedure Log_Error_With_Source (Text, Info_Log, Message : String) is
      package SF renames Ada.Strings.Fixed;
      package L1 renames Ada.Characters.Latin_1;

      Extra_Rows          : constant := 2;
      Line_Number_Padding : constant := 2;

      Separator : constant String := " | ";

      use Orka.Strings;
      use SF;

      use all type Orka.Terminals.Color;
      use all type Orka.Terminals.Style;
   begin
      declare
         Log_Parts : constant Orka.Strings.String_List := Split (Info_Log, ":", 3);

         Message_Parts : constant String_List := Split (Trim (+Log_Parts (3)), ": ", 2);

         Message_Kind_Color : constant Orka.Terminals.Color :=
           (if +Message_Parts (1) = "error" then
              Red
            elsif +Message_Parts (2) = "warning" then
              Yellow
            elsif +Message_Parts (2) = "note" then
              Cyan
            else
              Default);

         Message_Kind : constant String :=
           Orka.Terminals.Colorize (+Message_Parts (1) & ":", Foreground => Message_Kind_Color);
         Message_Value : constant String :=
           Orka.Terminals.Colorize (+Message_Parts (2), Attribute => Bold);

         -------------------------------------------------------------------------

         Lines : constant Orka.Strings.String_List := Orka.Strings.Split (Text, "" & L1.LF);

         Error_Row : constant Positive :=
           Positive'Value (+Orka.Strings.Split (+Log_Parts (2), "(", 2) (1));
         First_Row : constant Positive := Positive'Max (Lines'First, Error_Row - Extra_Rows);
         Last_Row  : constant Positive := Positive'Min (Lines'Last, Error_Row + Extra_Rows);

         Line_Digits : constant Positive := Trim (Last_Row'Image)'Length + Line_Number_Padding;
      begin
         Messages.Log (High, Message);

         for Row_Index in First_Row .. Last_Row loop
            declare
               Row_Image : constant String :=
                 SF.Tail (Trim (Row_Index'Image), Line_Digits);
               Row_Image_Colorized : constant String :=
                  Orka.Terminals.Colorize (Row_Image, Attribute => Dark);

               Line_Image : constant String := +Lines (Row_Index);

               First_Index_Line : constant Natural :=
                 SF.Index_Non_Blank (Line_Image, Going => Ada.Strings.Forward);
               Last_Index_Line : constant Natural :=
                 SF.Index_Non_Blank (Line_Image, Going => Ada.Strings.Backward);

               Error_Indicator : constant String :=
                 Orka.Terminals.Colorize
                   (Natural'Max (0, First_Index_Line - 1) * " " &
                    (Last_Index_Line - First_Index_Line + 1) * "^",
                    Foreground => Green,
                    Attribute  => Bold);

               Prefix_Image : constant String :=
                 (Row_Image'Length + Separator'Length) * " ";
            begin
               Messages.Log (High, Row_Image_Colorized  & Separator & Line_Image);
               if Row_Index = Error_Row then
                  Messages.Log (High, Prefix_Image  & Error_Indicator);
                  Messages.Log (High, Prefix_Image & ">>> " & Message_Kind & " " & Message_Value);
               end if;
            end;
         end loop;
      end;
   exception
      when others =>
         --  Continue if parsing Info_Log fails
         null;
   end Log_Error_With_Source;

   procedure Load_And_Compile
     (Object      : in out Module;
      Shader_Kind : GL.Objects.Shaders.Shader_Type;
      Location    : Resources.Locations.Location_Ptr;
      Path        : String) is
   begin
      if Path /= "" then
         pragma Assert (Object.Shaders (Shader_Kind).Is_Empty);
         declare
            Shader : GL.Objects.Shaders.Shader (Kind => Shader_Kind);
            Source : constant Resources.Byte_Array_Pointers.Pointer
              := Location.Read_Data (Path);

            Text : String renames Resources.Convert (Source.Get);
         begin
            Shader.Set_Source (Text);

            Shader.Compile;
            if not Shader.Compile_Status then
               declare
                  Log : constant String := Shader.Info_Log;
               begin
                  Log_Error_With_Source (Text, Log, "Compiling shader " & Path & " failed:");

                  raise Shader_Compile_Error with Path & ":" & Log;
               end;
            end if;
            Messages.Log (Notification, "Compiled shader " & Path);
            Messages.Log (Notification, "  size: " & Trim_Image (Orka.Strings.Lines (Text)) &
              " lines (" & Trim_Image (Source.Get.Value'Length) & " bytes)");
            Messages.Log (Notification, "  kind: " & Shader_Kind'Image);

            Object.Shaders (Shader_Kind).Replace_Element (Shader);
         end;
      end if;
   end Load_And_Compile;

   procedure Set_And_Compile
     (Object      : in out Module;
      Shader_Kind : GL.Objects.Shaders.Shader_Type;
      Source      : String) is
   begin
      if Source /= "" then
         pragma Assert (Object.Shaders (Shader_Kind).Is_Empty);
         declare
            Shader : GL.Objects.Shaders.Shader (Kind => Shader_Kind);
         begin
            Shader.Set_Source (Source);

            Shader.Compile;
            if not Shader.Compile_Status then
               declare
                  Log : constant String := Shader.Info_Log;
               begin
                  Log_Error_With_Source (Source, Log,
                    "Compiling " & Shader_Kind'Image & " shader failed:");

                  raise Shader_Compile_Error with Shader_Kind'Image & ":" & Log;
               end;
            end if;
            Messages.Log (Notification, "Compiled string with " &
              Trim_Image (Source'Length) & " characters");
            Messages.Log (Notification, "  size: " &
              Trim_Image (Orka.Strings.Lines (Source)) & " lines");
            Messages.Log (Notification, "  kind: " & Shader_Kind'Image);

            Object.Shaders (Shader_Kind).Replace_Element (Shader);
         end;
      end if;
   end Set_And_Compile;

   function Create_Module_From_Sources (VS, TCS, TES, GS, FS, CS : String := "")
     return Module
   is
      use GL.Objects.Shaders;
   begin
      return Result : Module do
         Set_And_Compile (Result, Vertex_Shader, VS);
         Set_And_Compile (Result, Tess_Control_Shader, TCS);
         Set_And_Compile (Result, Tess_Evaluation_Shader, TES);
         Set_And_Compile (Result, Geometry_Shader, GS);
         Set_And_Compile (Result, Fragment_Shader, FS);
         Set_And_Compile (Result, Compute_Shader, CS);
      end return;
   end Create_Module_From_Sources;

   function Create_Module
     (Location : Resources.Locations.Location_Ptr;
      VS, TCS, TES, GS, FS, CS : String := "") return Module
   is
      use GL.Objects.Shaders;
   begin
      return Result : Module do
         Load_And_Compile (Result, Vertex_Shader, Location, VS);
         Load_And_Compile (Result, Tess_Control_Shader, Location, TCS);
         Load_And_Compile (Result, Tess_Evaluation_Shader, Location, TES);
         Load_And_Compile (Result, Geometry_Shader, Location, GS);
         Load_And_Compile (Result, Fragment_Shader, Location, FS);
         Load_And_Compile (Result, Compute_Shader, Location, CS);
      end return;
   end Create_Module;

   procedure Attach_Shaders (Modules : Module_Array; Program : in out Programs.Program) is
      use GL.Objects.Shaders;

      procedure Attach (Subject : Module; Stage : GL.Objects.Shaders.Shader_Type) is
         Holder : Shader_Holder.Holder renames Subject.Shaders (Stage);
      begin
         if not Holder.Is_Empty then
            Program.GL_Program.Attach (Holder.Element);
         end if;
      end Attach;
   begin
      for Module of Modules loop
         Attach (Module, Vertex_Shader);
         Attach (Module, Tess_Control_Shader);
         Attach (Module, Tess_Evaluation_Shader);
         Attach (Module, Geometry_Shader);
         Attach (Module, Fragment_Shader);
         Attach (Module, Compute_Shader);
      end loop;
   end Attach_Shaders;

   procedure Detach_Shaders (Modules : Module_Array; Program : Programs.Program) is
      use GL.Objects.Shaders;

      procedure Detach (Holder : Shader_Holder.Holder) is
      begin
         if not Holder.Is_Empty then
            Program.GL_Program.Detach (Holder.Element);
         end if;
      end Detach;
   begin
      for Module of Modules loop
         Detach (Module.Shaders (Vertex_Shader));
         Detach (Module.Shaders (Tess_Control_Shader));
         Detach (Module.Shaders (Tess_Evaluation_Shader));
         Detach (Module.Shaders (Geometry_Shader));
         Detach (Module.Shaders (Fragment_Shader));
         Detach (Module.Shaders (Compute_Shader));
      end loop;
   end Detach_Shaders;

end Orka.Rendering.Programs.Modules;

--  SPDX-License-Identifier: Apache-2.0
--
--  Copyright (c) 2016 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 Ada.Characters.Latin_1;
with Ada.Strings.Fixed;

with GL.Debug;

with Orka.Strings;
with Orka.Terminals;

package body Orka.Rendering.Programs.Modules is

   use GL.Debug;
   package Messages is new GL.Debug.Messages (Third_Party, Other);

   function Trim_Image (Value : Integer) return String is
     (Orka.Strings.Trim (Integer'Image (Value)));

   package L1 renames Ada.Characters.Latin_1;

   use Orka.Strings;

   procedure Log_Error_With_Source (Text, Info_Log, Message : String) is
      package SF renames Ada.Strings.Fixed;

      Extra_Rows          : constant := 1;
      Line_Number_Padding : constant := 2;

      Separator : constant String := " | ";

      use SF;

      use all type Orka.Terminals.Color;
      use all type Orka.Terminals.Style;
   begin
      declare
         Log_Parts : constant Orka.Strings.String_List := Split (Info_Log, ":", 3);

         Message_Parts : constant String_List := Split (Trim (+Log_Parts (3)), ": ", 2);

         Message_Kind_Color : constant Orka.Terminals.Color :=
           (if +Message_Parts (1) = "error" then
              Red
            elsif +Message_Parts (1) = "warning" then
              Yellow
            elsif +Message_Parts (1) = "note" then
              Cyan
            else
              Default);

         Message_Kind : constant String :=
           Orka.Terminals.Colorize (+Message_Parts (1) & ":", Foreground => Message_Kind_Color);
         Message_Value : constant String :=
           Orka.Terminals.Colorize (+Message_Parts (2), Attribute => Bold);

         -------------------------------------------------------------------------

         Lines : constant Orka.Strings.String_List := Orka.Strings.Split (Text, "" & L1.LF);

         Error_Row : constant Positive :=
           Positive'Value (+Orka.Strings.Split (+Log_Parts (2), "(", 2) (1));
         First_Row : constant Positive := Positive'Max (Lines'First, Error_Row - Extra_Rows);
         Last_Row  : constant Positive := Positive'Min (Lines'Last, Error_Row + Extra_Rows);

         Line_Digits : constant Positive := Trim (Last_Row'Image)'Length + Line_Number_Padding;
      begin
         Messages.Log (High, Message);

         for Row_Index in First_Row .. Last_Row loop
            declare
               Row_Image : constant String :=
                 SF.Tail (Trim (Row_Index'Image), Line_Digits);
               Row_Image_Colorized : constant String :=
                  Orka.Terminals.Colorize (Row_Image, Attribute => Dark);

               Line_Image : constant String := +Lines (Row_Index);

               First_Index_Line : constant Natural :=
                 SF.Index_Non_Blank (Line_Image, Going => Ada.Strings.Forward);
               Last_Index_Line : constant Natural :=
                 SF.Index_Non_Blank (Line_Image, Going => Ada.Strings.Backward);

               Error_Indicator : constant String :=
                 Orka.Terminals.Colorize
                   (Natural'Max (0, First_Index_Line - 1) * " " &
                    (Last_Index_Line - First_Index_Line + 1) * "^",
                    Foreground => Green,
                    Attribute  => Bold);

               Prefix_Image : constant String :=
                 (Row_Image'Length + Separator'Length) * " ";
            begin
               Messages.Log (High, Row_Image_Colorized  & Separator & Line_Image);
               if Row_Index = Error_Row then
                  Messages.Log (High, Prefix_Image  & Error_Indicator);
                  Messages.Log (High, Prefix_Image & ">>> " & Message_Kind & " " & Message_Value);
               end if;
            end;
         end loop;
      end;
   exception
      when others =>
         --  Continue if parsing Info_Log fails
         null;
   end Log_Error_With_Source;

   procedure Load_And_Compile
     (Object      : in out Module;
      Shader_Kind : GL.Objects.Shaders.Shader_Type;
      Location    : Resources.Locations.Location_Ptr;
      Path        : String) is
   begin
      if Path /= "" then
         pragma Assert (Object.Shaders (Shader_Kind).Is_Empty);
         declare
            Shader : GL.Objects.Shaders.Shader (Kind => Shader_Kind);
            Source : constant Resources.Byte_Array_Pointers.Pointer
              := Location.Read_Data (Path);

            Text : String renames Resources.Convert (Source.Get);
         begin
            Shader.Set_Source (Text);

            Shader.Compile;
            if not Shader.Compile_Status then
               declare
                  Log : constant String := Shader.Info_Log;

                  Log_Parts : constant Orka.Strings.String_List := Split (Log, "" & L1.LF);
               begin
                  for Part of Log_Parts loop
                     Log_Error_With_Source (Text, +Part, "Compiling shader " & Path & " failed:");
                  end loop;

                  raise Shader_Compile_Error with Path & ":" & Log;
               end;
            end if;
            Messages.Log (Notification, "Compiled shader " & Path);
            Messages.Log (Notification, "  size: " & Trim_Image (Orka.Strings.Lines (Text)) &
              " lines (" & Trim_Image (Source.Get.Value'Length) & " bytes)");
            Messages.Log (Notification, "  kind: " & Shader_Kind'Image);

            Object.Shaders (Shader_Kind).Replace_Element (Shader);
         end;
      end if;
   end Load_And_Compile;

   procedure Set_And_Compile
     (Object      : in out Module;
      Shader_Kind : GL.Objects.Shaders.Shader_Type;
      Source      : String) is
   begin
      if Source /= "" then
         pragma Assert (Object.Shaders (Shader_Kind).Is_Empty);
         declare
            Shader : GL.Objects.Shaders.Shader (Kind => Shader_Kind);
         begin
            Shader.Set_Source (Source);

            Shader.Compile;
            if not Shader.Compile_Status then
               declare
                  Log : constant String := Shader.Info_Log;

                  Log_Parts : constant Orka.Strings.String_List := Split (Log, "" & L1.LF);
               begin
                  for Part of Log_Parts loop
                     Log_Error_With_Source (Source, +Part,
                       "Compiling " & Shader_Kind'Image & " shader failed:");
                  end loop;

                  raise Shader_Compile_Error with Shader_Kind'Image & ":" & Log;
               end;
            end if;
            Messages.Log (Notification, "Compiled string with " &
              Trim_Image (Source'Length) & " characters");
            Messages.Log (Notification, "  size: " &
              Trim_Image (Orka.Strings.Lines (Source)) & " lines");
            Messages.Log (Notification, "  kind: " & Shader_Kind'Image);

            Object.Shaders (Shader_Kind).Replace_Element (Shader);
         end;
      end if;
   end Set_And_Compile;

   function Create_Module_From_Sources (VS, TCS, TES, GS, FS, CS : String := "")
     return Module
   is
      use GL.Objects.Shaders;
   begin
      return Result : Module do
         Set_And_Compile (Result, Vertex_Shader, VS);
         Set_And_Compile (Result, Tess_Control_Shader, TCS);
         Set_And_Compile (Result, Tess_Evaluation_Shader, TES);
         Set_And_Compile (Result, Geometry_Shader, GS);
         Set_And_Compile (Result, Fragment_Shader, FS);
         Set_And_Compile (Result, Compute_Shader, CS);
      end return;
   end Create_Module_From_Sources;

   function Create_Module
     (Location : Resources.Locations.Location_Ptr;
      VS, TCS, TES, GS, FS, CS : String := "") return Module
   is
      use GL.Objects.Shaders;
   begin
      return Result : Module do
         Load_And_Compile (Result, Vertex_Shader, Location, VS);
         Load_And_Compile (Result, Tess_Control_Shader, Location, TCS);
         Load_And_Compile (Result, Tess_Evaluation_Shader, Location, TES);
         Load_And_Compile (Result, Geometry_Shader, Location, GS);
         Load_And_Compile (Result, Fragment_Shader, Location, FS);
         Load_And_Compile (Result, Compute_Shader, Location, CS);
      end return;
   end Create_Module;

   procedure Attach_Shaders (Modules : Module_Array; Program : in out Programs.Program) is
      use GL.Objects.Shaders;

      procedure Attach (Subject : Module; Stage : GL.Objects.Shaders.Shader_Type) is
         Holder : Shader_Holder.Holder renames Subject.Shaders (Stage);
      begin
         if not Holder.Is_Empty then
            Program.GL_Program.Attach (Holder.Element);
         end if;
      end Attach;
   begin
      for Module of Modules loop
         Attach (Module, Vertex_Shader);
         Attach (Module, Tess_Control_Shader);
         Attach (Module, Tess_Evaluation_Shader);
         Attach (Module, Geometry_Shader);
         Attach (Module, Fragment_Shader);
         Attach (Module, Compute_Shader);
      end loop;
   end Attach_Shaders;

   procedure Detach_Shaders (Modules : Module_Array; Program : Programs.Program) is
      use GL.Objects.Shaders;

      procedure Detach (Holder : Shader_Holder.Holder) is
      begin
         if not Holder.Is_Empty then
            Program.GL_Program.Detach (Holder.Element);
         end if;
      end Detach;
   begin
      for Module of Modules loop
         Detach (Module.Shaders (Vertex_Shader));
         Detach (Module.Shaders (Tess_Control_Shader));
         Detach (Module.Shaders (Tess_Evaluation_Shader));
         Detach (Module.Shaders (Geometry_Shader));
         Detach (Module.Shaders (Fragment_Shader));
         Detach (Module.Shaders (Compute_Shader));
      end loop;
   end Detach_Shaders;

end Orka.Rendering.Programs.Modules;

orka: Handle and print multiple errors in the info log of a shader

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


-----------------------------------------------------------------------
--  security-random -- Random numbers for nonce, secret keys, token generation
--  Copyright (C) 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 Interfaces.C;
with Ada.Calendar;
with Ada.Calendar.Conversions;
with Util.Encoders.Base64;

package body Security.Random is

   use Interfaces;

   --  ------------------------------
   --  Initialize the random generator.
   --  ------------------------------
   overriding
   procedure Initialize (Gen : in out Generator) is
   begin
      Gen.Rand.Reset;
   end Initialize;

   --  ------------------------------
   --  Fill the array with pseudo-random numbers.
   --  ------------------------------
   procedure Generate (Gen  : in out Generator;
                       Into : out Ada.Streams.Stream_Element_Array) is
   begin
      Gen.Rand.Generate (Into);
   end Generate;

   --  ------------------------------
   --  Generate a random sequence of bits and convert the result
   --  into a string in base64url.
   --  ------------------------------
   function Generate (Gen  : in out Generator'Class;
                      Bits : in Positive) return String is
      use type Ada.Streams.Stream_Element_Offset;

      Rand_Count : constant Ada.Streams.Stream_Element_Offset
        := Ada.Streams.Stream_Element_Offset (4 * ((Bits + 31) / 32));

      Rand    : Ada.Streams.Stream_Element_Array (0 .. Rand_Count - 1);
      Buffer  : Ada.Streams.Stream_Element_Array (0 .. Rand_Count * 3);
      Encoder : Util.Encoders.Base64.Encoder;
      Last    : Ada.Streams.Stream_Element_Offset;
      Encoded : Ada.Streams.Stream_Element_Offset;
   begin
      --  Generate the random sequence.
      Gen.Generate (Rand);

      --  Encode the random stream in base64url and save it into the result string.
      Encoder.Set_URL_Mode (True);
      Encoder.Transform (Data => Rand, Into => Buffer,
                         Last => Last, Encoded => Encoded);
      declare
         Result : String (1 .. Natural (Encoded + 1));
      begin
         for I in 0 .. Encoded loop
            Result (Natural (I + 1)) := Character'Val (Buffer (I));
         end loop;
         return Result;
      end;
   end Generate;

   --  ------------------------------
   --  Generate a random sequence of bits, convert the result
   --  into a string in base64url and append it to the buffer.
   --  ------------------------------
   procedure Generate (Gen  : in out Generator'Class;
                       Bits : in Positive;
                       Into : in out Ada.Strings.Unbounded.Unbounded_String) is
      use type Ada.Streams.Stream_Element_Offset;

      Rand_Count : constant Ada.Streams.Stream_Element_Offset
        := Ada.Streams.Stream_Element_Offset (4 * ((Bits + 31) / 32));

      Rand    : Ada.Streams.Stream_Element_Array (0 .. Rand_Count - 1);
      Buffer  : Ada.Streams.Stream_Element_Array (0 .. Rand_Count * 3);
      Encoder : Util.Encoders.Base64.Encoder;
      Last    : Ada.Streams.Stream_Element_Offset;
      Encoded : Ada.Streams.Stream_Element_Offset;
   begin
      --  Generate the random sequence.
      Gen.Generate (Rand);

      --  Encode the random stream in base64url and save it into the result string.
      Encoder.Set_URL_Mode (True);
      Encoder.Transform (Data => Rand, Into => Buffer,
                         Last => Last, Encoded => Encoded);
      for I in 0 .. Encoded loop
         Ada.Strings.Unbounded.Append (Into, Character'Val (Buffer (I)));
      end loop;
   end Generate;

   --  Protected type to allow using the random generator by several tasks.
   protected body Raw_Generator is

      procedure Generate (Into : out Ada.Streams.Stream_Element_Array) is
         use Ada.Streams;

         Size : constant Ada.Streams.Stream_Element_Offset := Into'Last / 4;
      begin
         --  Generate the random sequence.
         for I in 0 .. Size loop
            declare
               Value : constant Unsigned_32 := Id_Random.Random (Rand);
            begin
               Into (4 * I)     := Stream_Element (Value and 16#0FF#);
               Into (4 * I + 1) := Stream_Element (Shift_Right (Value, 8) and 16#0FF#);
               Into (4 * I + 2) := Stream_Element (Shift_Right (Value, 16) and 16#0FF#);
               Into (4 * I + 3) := Stream_Element (Shift_Right (Value, 24) and 16#0FF#);
            end;
         end loop;
      end Generate;

      procedure Reset is
         Now  : constant Ada.Calendar.Time := Ada.Calendar.Clock;
         S    : constant Ada.Calendar.Day_Duration := Ada.Calendar.Seconds (Now);
         Sec  : Interfaces.C.long;
         Nsec : Interfaces.C.long;
      begin
         Ada.Calendar.Conversions.To_Struct_Timespec (S, Sec, Nsec);
         Id_Random.Reset (Rand, Integer (Unsigned_32 (Sec) xor Unsigned_32 (Nsec)));
      end Reset;

   end Raw_Generator;

end Security.Random;

-----------------------------------------------------------------------
--  security-random -- Random numbers for nonce, secret keys, token generation
--  Copyright (C) 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 Interfaces.C;
with Ada.Calendar;
with Ada.Calendar.Conversions;
with Util.Encoders.Base64;

package body Security.Random is

   use Interfaces;

   --  ------------------------------
   --  Initialize the random generator.
   --  ------------------------------
   overriding
   procedure Initialize (Gen : in out Generator) is
   begin
      Gen.Rand.Reset;
   end Initialize;

   --  ------------------------------
   --  Fill the array with pseudo-random numbers.
   --  ------------------------------
   procedure Generate (Gen  : in out Generator;
                       Into : out Ada.Streams.Stream_Element_Array) is
   begin
      Gen.Rand.Generate (Into);
   end Generate;

   --  ------------------------------
   --  Generate a random sequence of bits and convert the result
   --  into a string in base64url.
   --  ------------------------------
   function Generate (Gen  : in out Generator'Class;
                      Bits : in Positive) return String is
      use type Ada.Streams.Stream_Element_Offset;

      Rand_Count : constant Ada.Streams.Stream_Element_Offset
        := Ada.Streams.Stream_Element_Offset (4 * ((Bits + 31) / 32));

      Rand    : Ada.Streams.Stream_Element_Array (0 .. Rand_Count - 1);
      Buffer  : Ada.Streams.Stream_Element_Array (0 .. Rand_Count * 3);
      Encoder : Util.Encoders.Base64.Encoder;
      Last    : Ada.Streams.Stream_Element_Offset;
      Encoded : Ada.Streams.Stream_Element_Offset;
   begin
      --  Generate the random sequence.
      Gen.Generate (Rand);

      --  Encode the random stream in base64url and save it into the result string.
      Encoder.Set_URL_Mode (True);
      Encoder.Transform (Data => Rand, Into => Buffer,
                         Last => Last, Encoded => Encoded);
      declare
         Result : String (1 .. Natural (Encoded + 1));
      begin
         for I in 0 .. Encoded loop
            Result (Natural (I + 1)) := Character'Val (Buffer (I));
         end loop;
         return Result;
      end;
   end Generate;

   --  ------------------------------
   --  Generate a random sequence of bits, convert the result
   --  into a string in base64url and append it to the buffer.
   --  ------------------------------
   procedure Generate (Gen  : in out Generator'Class;
                       Bits : in Positive;
                       Into : in out Ada.Strings.Unbounded.Unbounded_String) is
      use type Ada.Streams.Stream_Element_Offset;

      Rand_Count : constant Ada.Streams.Stream_Element_Offset
        := Ada.Streams.Stream_Element_Offset (4 * ((Bits + 31) / 32));

      Rand    : Ada.Streams.Stream_Element_Array (0 .. Rand_Count - 1);
      Buffer  : Ada.Streams.Stream_Element_Array (0 .. Rand_Count * 3);
      Encoder : Util.Encoders.Base64.Encoder;
      Last    : Ada.Streams.Stream_Element_Offset;
      Encoded : Ada.Streams.Stream_Element_Offset;
   begin
      --  Generate the random sequence.
      Gen.Generate (Rand);

      --  Encode the random stream in base64url and save it into the result string.
      Encoder.Set_URL_Mode (True);
      Encoder.Transform (Data => Rand, Into => Buffer,
                         Last => Last, Encoded => Encoded);
      for I in 0 .. Encoded loop
         Ada.Strings.Unbounded.Append (Into, Character'Val (Buffer (I)));
      end loop;
   end Generate;

   --  Protected type to allow using the random generator by several tasks.
   protected body Raw_Generator is

      procedure Generate (Into : out Ada.Streams.Stream_Element_Array) is
         use Ada.Streams;

         Size   : constant Ada.Streams.Stream_Element_Offset := Into'Length / 4;
         Remain : constant Ada.Streams.Stream_Element_Offset := Into'Length mod 4;
         Value  : Unsigned_32;
      begin
         --  Generate the random sequence (fill 32-bits at a time for each random call).
         for I in 0 .. Size - 1 loop
            Value := Id_Random.Random (Rand);
            Into (Into'First + 4 * I)     := Stream_Element (Value and 16#0FF#);
            Into (Into'First + 4 * I + 1) := Stream_Element (Shift_Right (Value, 8) and 16#0FF#);
            Into (Into'First + 4 * I + 2) := Stream_Element (Shift_Right (Value, 16) and 16#0FF#);
            Into (Into'First + 4 * I + 3) := Stream_Element (Shift_Right (Value, 24) and 16#0FF#);
         end loop;

         --  Fill the remaining bytes.
         if Remain > 0 then
            Value := Id_Random.Random (Rand);
            for I in 0 .. Remain - 1 loop
               Into (Into'Last - I) := Stream_Element (Value and 16#0FF#);
               Value := Shift_Right (Value, 8);
            end loop;
         end if;
      end Generate;

      procedure Reset is
         Now  : constant Ada.Calendar.Time := Ada.Calendar.Clock;
         S    : constant Ada.Calendar.Day_Duration := Ada.Calendar.Seconds (Now);
         Sec  : Interfaces.C.long;
         Nsec : Interfaces.C.long;
      begin
         Ada.Calendar.Conversions.To_Struct_Timespec (S, Sec, Nsec);
         Id_Random.Reset (Rand, Integer (Unsigned_32 (Sec) xor Unsigned_32 (Nsec)));
      end Reset;

   end Raw_Generator;

end Security.Random;

Update the Generate procedure implementation to correctly fill arrays not aligned on 32-bits


------------------------------------------------------------------------------
-- Copyright (c) 2015-2016, Natacha Porté                                   --
--                                                                          --
-- Permission to use, copy, modify, and distribute this software for any    --
-- purpose with or without fee is hereby granted, provided that the above   --
-- copyright notice and this permission notice appear in all copies.        --
--                                                                          --
-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES --
-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF         --
-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR  --
-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES   --
-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN    --
-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF  --
-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.           --
------------------------------------------------------------------------------

with Ada.Strings.Unbounded;
with Natools.Smaz.Original;

package body Natools.Smaz.Tests is

   function Image (S : Ada.Streams.Stream_Element_Array) return String;

   procedure Roundtrip_Test
     (Test : in out NT.Test;
      Dict : in Dictionary;
      Decompressed : in String;
      Compressed : in Ada.Streams.Stream_Element_Array);

   ------------------------------
   -- Local Helper Subprograms --
   ------------------------------

   function Image (S : Ada.Streams.Stream_Element_Array) return String is
      use Ada.Strings.Unbounded;
      Result : Unbounded_String;
   begin
      for I in S'Range loop
         Append (Result, Ada.Streams.Stream_Element'Image (S (I)));
      end loop;

      return To_String (Result);
   end Image;

   procedure Roundtrip_Test
     (Test : in out NT.Test;
      Dict : in Dictionary;
      Decompressed : in String;
      Compressed : in Ada.Streams.Stream_Element_Array)
   is
      use type Ada.Streams.Stream_Element_Array;
      use type Ada.Streams.Stream_Element_Offset;
   begin
      declare
         First_OK : Boolean := False;
      begin
         declare
            Buffer : constant Ada.Streams.Stream_Element_Array
              := Compress (Dict, Decompressed);
         begin
            First_OK := True;

            if Buffer /= Compressed then
               Test.Fail ("Bad compression of """ & Decompressed & '"');
               Test.Info ("Found:   " & Image (Buffer));
               Test.Info ("Expected:" & Image (Compressed));

               declare
                  Round : constant String := Decompress (Dict, Buffer);
               begin
                  if Round /= Decompressed then
                     Test.Info ("Roundtrip failed, got: """ & Round & '"');
                  else
                     Test.Info ("Roundtrip OK");
                  end if;
               end;
            end if;
         end;
      exception
         when Error : others =>
            if not First_OK then
               Test.Info ("During compression of """ & Decompressed & '"');
            end if;

            Test.Report_Exception (Error, NT.Fail);
      end;

      declare
         First_OK : Boolean := False;
      begin
         declare
            Buffer : constant String := Decompress (Dict, Compressed);
         begin
            First_OK := True;

            if Buffer /= Decompressed then
               Test.Fail ("Bad decompression of " & Image (Compressed));
               Test.Info ("Found:   """ & Buffer & '"');
               Test.Info ("Expected:""" & Decompressed & '"');

               declare
                  Round : constant Ada.Streams.Stream_Element_Array
                    := Compress (Dict, Buffer);
               begin
                  if Round /= Compressed then
                     Test.Info ("Roundtrip failed, got: " & Image (Round));
                  else
                     Test.Info ("Roundtrip OK");
                  end if;
               end;
            end if;
         end;
      exception
         when Error : others =>
            if not First_OK then
               Test.Info ("During compression of " & Image (Compressed));
            end if;

            Test.Report_Exception (Error, NT.Fail);
      end;
   end Roundtrip_Test;

   -------------------------
   -- Complete Test Suite --
   -------------------------

   procedure All_Tests (Report : in out NT.Reporter'Class) is
   begin
      Sample_Strings (Report);
   end All_Tests;

   ----------------------
   -- Individual Tests --
   ----------------------

   procedure Sample_Strings (Report : in out NT.Reporter'Class) is
      Test : NT.Test := Report.Item ("Roundtrip on sample strings");
   begin
      Roundtrip_Test (Test, Original.Dictionary,
         "This is a small string",
         (254, 84, 76, 56, 172, 62, 173, 152, 62, 195, 70));
      Roundtrip_Test (Test, Original.Dictionary,
         "foobar",
         (220, 6, 90, 79));
      Roundtrip_Test (Test, Original.Dictionary,
         "the end",
         (1, 171, 61));
      Roundtrip_Test (Test, Original.Dictionary,
         "not-a-g00d-Exampl333",
         (132, 204, 4, 204, 59, 255, 12, 48, 48, 100, 45, 69, 120, 97, 109,
           112, 108, 51, 51, 51));
      Roundtrip_Test (Test, Original.Dictionary,
         "Smaz is a simple compression library",
         (254, 83, 173, 219, 56, 172, 62, 226, 60, 87, 161, 45, 60, 33, 166,
           107, 205, 8, 90, 130, 12, 83));
      Roundtrip_Test (Test, Original.Dictionary,
         "Nothing is more difficult, and therefore more precious, "
           & "than to be able to decide",
         (254, 78, 223, 102, 99, 116, 45, 42, 11, 129, 44, 44, 131, 38, 22, 3,
           148, 63, 210, 68, 11, 45, 42, 11, 60, 33, 28, 144, 164, 36, 203,
           143, 96, 92, 25, 90, 87, 82, 165, 215, 237, 2));
      Roundtrip_Test (Test, Original.Dictionary,
         "this is an example of what works very well with smaz",
         (155, 56, 172, 41, 2, 250, 4, 45, 60, 87, 32, 159, 135, 65, 42, 254,
           107, 23, 231, 71, 145, 152, 243, 227, 10, 173, 219));
      Roundtrip_Test (Test, Original.Dictionary,
         "1000 numbers 2000 will 10 20 30 compress very little",
         (255, 3, 49, 48, 48, 48, 236, 38, 45, 92, 221, 0, 255, 3, 50, 48, 48,
           48, 243, 152, 0, 255, 7, 49, 48, 32, 50, 48, 32, 51,
           48, 161, 45, 60, 33, 166, 0, 231, 71, 151, 3, 3, 87));
   exception
      when Error : others => Test.Report_Exception (Error);
   end Sample_Strings;

end Natools.Smaz.Tests;

------------------------------------------------------------------------------
-- Copyright (c) 2015-2016, Natacha Porté                                   --
--                                                                          --
-- Permission to use, copy, modify, and distribute this software for any    --
-- purpose with or without fee is hereby granted, provided that the above   --
-- copyright notice and this permission notice appear in all copies.        --
--                                                                          --
-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES --
-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF         --
-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR  --
-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES   --
-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN    --
-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF  --
-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.           --
------------------------------------------------------------------------------

with Ada.Strings.Unbounded;
with Natools.Smaz.Original;

package body Natools.Smaz.Tests is

   function Image (S : Ada.Streams.Stream_Element_Array) return String;

   procedure Roundtrip_Test
     (Test : in out NT.Test;
      Dict : in Dictionary;
      Decompressed : in String;
      Compressed : in Ada.Streams.Stream_Element_Array);

   ------------------------------
   -- Local Helper Subprograms --
   ------------------------------

   function Image (S : Ada.Streams.Stream_Element_Array) return String is
      use Ada.Strings.Unbounded;
      Result : Unbounded_String;
   begin
      for I in S'Range loop
         Append (Result, Ada.Streams.Stream_Element'Image (S (I)));
      end loop;

      return To_String (Result);
   end Image;

   procedure Roundtrip_Test
     (Test : in out NT.Test;
      Dict : in Dictionary;
      Decompressed : in String;
      Compressed : in Ada.Streams.Stream_Element_Array)
   is
      use type Ada.Streams.Stream_Element_Array;
      use type Ada.Streams.Stream_Element_Offset;
   begin
      declare
         First_OK : Boolean := False;
      begin
         declare
            Buffer : constant Ada.Streams.Stream_Element_Array
              := Compress (Dict, Decompressed);
         begin
            First_OK := True;

            if Buffer /= Compressed then
               Test.Fail ("Bad compression of """ & Decompressed & '"');
               Test.Info ("Found:   " & Image (Buffer));
               Test.Info ("Expected:" & Image (Compressed));

               declare
                  Round : constant String := Decompress (Dict, Buffer);
               begin
                  if Round /= Decompressed then
                     Test.Info ("Roundtrip failed, got: """ & Round & '"');
                  else
                     Test.Info ("Roundtrip OK");
                  end if;
               end;
            end if;
         end;
      exception
         when Error : others =>
            if not First_OK then
               Test.Info ("During compression of """ & Decompressed & '"');
            end if;

            Test.Report_Exception (Error, NT.Fail);
      end;

      declare
         First_OK : Boolean := False;
      begin
         declare
            Buffer : constant String := Decompress (Dict, Compressed);
         begin
            First_OK := True;

            if Buffer /= Decompressed then
               Test.Fail ("Bad decompression of " & Image (Compressed));
               Test.Info ("Found:   """ & Buffer & '"');
               Test.Info ("Expected:""" & Decompressed & '"');

               declare
                  Round : constant Ada.Streams.Stream_Element_Array
                    := Compress (Dict, Buffer);
               begin
                  if Round /= Compressed then
                     Test.Info ("Roundtrip failed, got: " & Image (Round));
                  else
                     Test.Info ("Roundtrip OK");
                  end if;
               end;
            end if;
         end;
      exception
         when Error : others =>
            if not First_OK then
               Test.Info ("During compression of " & Image (Compressed));
            end if;

            Test.Report_Exception (Error, NT.Fail);
      end;
   end Roundtrip_Test;

   -------------------------
   -- Complete Test Suite --
   -------------------------

   procedure All_Tests (Report : in out NT.Reporter'Class) is
   begin
      Sample_Strings (Report);
   end All_Tests;

   ----------------------
   -- Individual Tests --
   ----------------------

   procedure Sample_Strings (Report : in out NT.Reporter'Class) is
      Test : NT.Test := Report.Item ("Roundtrip on sample strings");
   begin
      Roundtrip_Test (Test, Original.Dictionary,
         "This is a small string",
         (254, 84, 76, 56, 172, 62, 173, 152, 62, 195, 70));
      Roundtrip_Test (Test, Original.Dictionary,
         "foobar",
         (220, 6, 90, 79));
      Roundtrip_Test (Test, Original.Dictionary,
         "the end",
         (1, 171, 61));
      Roundtrip_Test (Test, Original.Dictionary,
         "not-a-g00d-Exampl333",
         (132, 204, 4, 204, 59, 255, 12, 48, 48, 100, 45, 69, 120, 97, 109,
           112, 108, 51, 51, 51));
      Roundtrip_Test (Test, Original.Dictionary,
         "Smaz is a simple compression library",
         (254, 83, 173, 219, 56, 172, 62, 226, 60, 87, 161, 45, 60, 33, 166,
           107, 205, 8, 90, 130, 12, 83));
      Roundtrip_Test (Test, Original.Dictionary,
         "Nothing is more difficult, and therefore more precious, "
           & "than to be able to decide",
         (254, 78, 223, 102, 99, 116, 45, 42, 11, 129, 44, 44, 131, 38, 22, 3,
           148, 63, 210, 68, 11, 45, 42, 11, 60, 33, 28, 144, 164, 36, 203,
           143, 96, 92, 25, 90, 87, 82, 165, 215, 237, 2));
      Roundtrip_Test (Test, Original.Dictionary,
         "this is an example of what works very well with smaz",
         (155, 56, 172, 41, 2, 250, 4, 45, 60, 87, 32, 159, 135, 65, 42, 254,
           107, 23, 231, 71, 145, 152, 243, 227, 10, 173, 219));
      Roundtrip_Test (Test, Original.Dictionary,
         "1000 numbers 2000 will 10 20 30 compress very little",
         (255, 3, 49, 48, 48, 48, 236, 38, 45, 92, 221, 0, 255, 3, 50, 48, 48,
           48, 243, 152, 0, 255, 7, 49, 48, 32, 50, 48, 32, 51,
           48, 161, 45, 60, 33, 166, 0, 231, 71, 151, 3, 3, 87));
      Roundtrip_Test (Test, Original.Dictionary,
         ": : : :",
         (255, 6, 58, 32, 58, 32, 58, 32, 58));
   exception
      when Error : others => Test.Report_Exception (Error);
   end Sample_Strings;

end Natools.Smaz.Tests;

smaz-tests: add a test case showing bug in compressed size estimation


-----------------------------------------------------------------------
--  asf.sessions.factory -- ASF Sessions factory
--  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.Finalization;
with Util.Strings;
with Ada.Strings.Unbounded;
with Util.Concurrent.Locks;
with Ada.Containers.Hashed_Maps;
with Ada.Numerics.Discrete_Random;
with Interfaces;
with Ada.Streams;

--  The ASF.Sessions.Factory package is a factory for creating, searching
--  and deleting sessions.
package ASF.Sessions.Factory is

   type Session_Factory is tagged limited private;

   --  Create a new session
   procedure Create_Session (Factory : in out Session_Factory;
                             Result  : out Session);

   --  Allocate a unique and random session identifier.  The default implementation
   --  generates a 256 bit random number that it serializes as base64 in the string.
   --  Upon successful completion, the sequence string buffer is allocated and
   --  returned in Id.  The buffer will be freed when the session is removed.
   procedure Allocate_Session_Id (Factory : in out Session_Factory;
                                  Id      : out Ada.Strings.Unbounded.String_Access);

   --  Deletes the session.
   procedure Delete_Session (Factory : in out Session_Factory;
                             Sess    : in out Session);

   --  Finds the session knowing the session identifier.
   --  If the session is found, the last access time is updated.
   --  Otherwise, the null session object is returned.
   procedure Find_Session (Factory : in out Session_Factory;
                           Id      : in String;
                           Result  : out Session);

   --  Returns the maximum time interval, in seconds, that the servlet container will
   --  keep this session open between client accesses. After this interval, the servlet
   --  container will invalidate the session. The maximum time interval can be set with
   --  the Set_Max_Inactive_Interval method.
   --  A negative time indicates the session should never timeout.
   function Get_Max_Inactive_Interval (Factory : in Session_Factory) return Duration;

   --  Specifies the time, in seconds, between client requests before the servlet
   --  container will invalidate this session. A negative time indicates the session
   --  should never timeout.
   procedure Set_Max_Inactive_Interval (Factory  : in out Session_Factory;
                                        Interval : in Duration);

private

   use Util.Strings;

   package Session_Maps is new
     Ada.Containers.Hashed_Maps (Key_Type        => Name_Access,
                                 Element_Type    => Session,
                                 Hash            => Hash,
                                 Equivalent_Keys => Util.Strings.Equivalent_Keys);

   package Id_Random is new Ada.Numerics.Discrete_Random (Interfaces.Unsigned_32);

   type Session_Factory is new Ada.Finalization.Limited_Controlled with record
      Lock         : Util.Concurrent.Locks.RW_Lock;

      --  Id to session map.
      Sessions     : Session_Maps.Map;

      --  Max inactive time in seconds.
      Max_Inactive : Duration := DEFAULT_INACTIVE_TIMEOUT;

      --  Random number generator used for ID generation.
      Random       : Id_Random.Generator;

      --  Number of 32-bit random numbers used for the ID generation.
      Id_Size      : Ada.Streams.Stream_Element_Offset := 8;
   end record;

   --  Initialize the session factory.
   overriding
   procedure Initialize (Factory : in out Session_Factory);

end ASF.Sessions.Factory;

-----------------------------------------------------------------------
--  asf.sessions.factory -- ASF Sessions factory
--  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.Finalization;
with Util.Strings;
with Ada.Strings.Unbounded;
with Util.Concurrent.Locks;
with Ada.Containers.Hashed_Maps;
with Ada.Numerics.Discrete_Random;
with Interfaces;
with Ada.Streams;

--  The ASF.Sessions.Factory package is a factory for creating, searching
--  and deleting sessions.
package ASF.Sessions.Factory is

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

   --  Create a new session
   procedure Create_Session (Factory : in out Session_Factory;
                             Result  : out Session);

   --  Allocate a unique and random session identifier.  The default implementation
   --  generates a 256 bit random number that it serializes as base64 in the string.
   --  Upon successful completion, the sequence string buffer is allocated and
   --  returned in Id.  The buffer will be freed when the session is removed.
   procedure Allocate_Session_Id (Factory : in out Session_Factory;
                                  Id      : out Ada.Strings.Unbounded.String_Access);

   --  Deletes the session.
   procedure Delete_Session (Factory : in out Session_Factory;
                             Sess    : in out Session);

   --  Finds the session knowing the session identifier.
   --  If the session is found, the last access time is updated.
   --  Otherwise, the null session object is returned.
   procedure Find_Session (Factory : in out Session_Factory;
                           Id      : in String;
                           Result  : out Session);

   --  Returns the maximum time interval, in seconds, that the servlet container will
   --  keep this session open between client accesses. After this interval, the servlet
   --  container will invalidate the session. The maximum time interval can be set with
   --  the Set_Max_Inactive_Interval method.
   --  A negative time indicates the session should never timeout.
   function Get_Max_Inactive_Interval (Factory : in Session_Factory) return Duration;

   --  Specifies the time, in seconds, between client requests before the servlet
   --  container will invalidate this session. A negative time indicates the session
   --  should never timeout.
   procedure Set_Max_Inactive_Interval (Factory  : in out Session_Factory;
                                        Interval : in Duration);

private

   use Util.Strings;

   package Session_Maps is new
     Ada.Containers.Hashed_Maps (Key_Type        => Name_Access,
                                 Element_Type    => Session,
                                 Hash            => Hash,
                                 Equivalent_Keys => Util.Strings.Equivalent_Keys);

   package Id_Random is new Ada.Numerics.Discrete_Random (Interfaces.Unsigned_32);

   type Session_Factory is new Ada.Finalization.Limited_Controlled with record
      Lock         : Util.Concurrent.Locks.RW_Lock;

      --  Id to session map.
      Sessions     : Session_Maps.Map;

      --  Max inactive time in seconds.
      Max_Inactive : Duration := DEFAULT_INACTIVE_TIMEOUT;

      --  Random number generator used for ID generation.
      Random       : Id_Random.Generator;

      --  Number of 32-bit random numbers used for the ID generation.
      Id_Size      : Ada.Streams.Stream_Element_Offset := 8;
   end record;

   --  Initialize the session factory.
   overriding
   procedure Initialize (Factory : in out Session_Factory);

end ASF.Sessions.Factory;

Fix compilation issue: the Session_Factory must expose the Finalize procedure so that it can be overriden by derived types.


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

with ASF.Applications;

with AWA.Modules;
with AWA.Storages.Services;
with AWA.Storages.Servlets;

--  == Storage Module ==
--  The `Storage_Module` type represents the storage module.  An instance of the storage
--  module must be declared and registered when the application is created and initialized.
--  The storage module is associated with the storage service which provides and implements
--  the storage management operations.
--
--  @include-permission storages.xml
--  @include-config storages.xml
package AWA.Storages.Modules is

   NAME : constant String := "storages";

   type Storage_Module is new AWA.Modules.Module with private;
   type Storage_Module_Access is access all Storage_Module'Class;

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

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

   --  Create a storage manager.  This operation can be overridden to provide another
   --  storage service implementation.
   function Create_Storage_Manager (Plugin : in Storage_Module)
                                    return Services.Storage_Service_Access;

   --  Get the storage module instance associated with the current application.
   function Get_Storage_Module return Storage_Module_Access;

   --  Get the storage manager instance associated with the current application.
   function Get_Storage_Manager return Services.Storage_Service_Access;

private

   type Storage_Module is new AWA.Modules.Module with record
      Manager         : Services.Storage_Service_Access := null;
      Storage_Servlet : aliased AWA.Storages.Servlets.Storage_Servlet;
   end record;

end AWA.Storages.Modules;

-----------------------------------------------------------------------
--  awa-storages-modules -- Storage management module
--  Copyright (C) 2012, 2018, 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 ASF.Applications;

with AWA.Modules;
with AWA.Storages.Services;
with AWA.Storages.Servlets;

--  == Storage Module ==
--  The `Storage_Module` type represents the storage module.  An instance of the storage
--  module must be declared and registered when the application is created and initialized.
--  The storage module is associated with the storage service which provides and implements
--  the storage management operations.
--
--  @include-permission storages.xml
--  @include-config storages.xml
package AWA.Storages.Modules is

   NAME : constant String := "storages";

   type Storage_Module is new AWA.Modules.Module with private;
   type Storage_Module_Access is access all Storage_Module'Class;

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

   --  Configures the module after its initialization and after having read its XML configuration.
   overriding
   procedure Configure (Plugin : in out Storage_Module;
                        Props  : in ASF.Applications.Config);

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

   --  Create a storage manager.  This operation can be overridden to provide another
   --  storage service implementation.
   function Create_Storage_Manager (Plugin : in Storage_Module)
                                    return Services.Storage_Service_Access;

   --  Get the storage module instance associated with the current application.
   function Get_Storage_Module return Storage_Module_Access;

   --  Get the storage manager instance associated with the current application.
   function Get_Storage_Manager return Services.Storage_Service_Access;

private

   type Storage_Module is new AWA.Modules.Module with record
      Manager         : Services.Storage_Service_Access := null;
      Storage_Servlet : aliased AWA.Storages.Servlets.Storage_Servlet;
   end record;

end AWA.Storages.Modules;

Add Configure procedure to configure the storage module


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

with ASF.Servlets.Faces;
with ASF.Servlets.Files;
with ASF.Servlets.Ajax;
with ASF.Filters.Dump;
with ASF.Servlets.Measures;

with ASF.Security.Servlets;
with ASF.Converters.Sizes;

with AWA.Users.Servlets;
with AWA.Users.Modules;
with AWA.Mail.Modules;
with AWA.Blogs.Modules;
with AWA.Applications;
with AWA.Workspaces.Modules;
with AWA.Storages.Modules;
with AWA.Images.Modules;
with AWA.Questions.Modules;
with AWA.Services.Filters;
with AWA.Converters.Dates;

with Atlas.Microblog.Modules;
package Atlas.Applications is

   CONFIG_PATH  : constant String := "/atlas";
   CONTEXT_PATH : constant String := "/atlas";

   ATLAS_NS_URI : aliased constant String := "http://code.google.com/p/ada-awa/atlas";

   --  Given an Email address, return the Gravatar link to the user image.
   --  (See http://en.gravatar.com/site/implement/hash/ and
   --  http://en.gravatar.com/site/implement/images/)
   function Get_Gravatar_Link (Email : in String) return String;

   --  EL function to convert an Email address to a Gravatar image.
   function To_Gravatar_Link (Email : in Util.Beans.Objects.Object)
                              return Util.Beans.Objects.Object;

   type Application is new AWA.Applications.Application with private;
   type Application_Access is access all Application'Class;

   --  Initialize the application.
   procedure Initialize (App : in Application_Access);

   --  Initialize the ASF components provided by the application.
   --  This procedure is called by Initialize.
   --  It should register the component factories used by the application.
   overriding
   procedure Initialize_Components (App : in out Application);

   --  Initialize the servlets provided by the application.
   --  This procedure is called by Initialize.
   --  It should register the application servlets.
   overriding
   procedure Initialize_Servlets (App : in out Application);

   --  Initialize the filters provided by the application.
   --  This procedure is called by Initialize.
   --  It should register the application filters.
   overriding
   procedure Initialize_Filters (App : in out Application);

   --  Initialize the AWA modules provided by the application.
   --  This procedure is called by Initialize.
   --  It should register the modules used by the application.
   overriding
   procedure Initialize_Modules (App : in out Application);

private

   type Application is new AWA.Applications.Application with record
      Self              : Application_Access;
      --  Application servlets and filters (add new servlet and filter instances here).
      Faces             : aliased ASF.Servlets.Faces.Faces_Servlet;
      Ajax              : aliased ASF.Servlets.Ajax.Ajax_Servlet;
      Files             : aliased ASF.Servlets.Files.File_Servlet;
      Dump              : aliased ASF.Filters.Dump.Dump_Filter;
      Service_Filter    : aliased AWA.Services.Filters.Service_Filter;
      Measures          : aliased ASF.Servlets.Measures.Measure_Servlet;

      --  Authentication servlet and filter.
      Auth              : aliased ASF.Security.Servlets.Request_Auth_Servlet;
      Verify_Auth       : aliased AWA.Users.Servlets.Verify_Auth_Servlet;

      --  Converters shared by web requests.
      Rel_Date_Converter : aliased AWA.Converters.Dates.Relative_Date_Converter;
      Size_Converter     : aliased ASF.Converters.Sizes.Size_Converter;

      --  The application modules.
      User_Module       : aliased AWA.Users.Modules.User_Module;
      Workspace_Module  : aliased AWA.Workspaces.Modules.Workspace_Module;
      Blog_Module       : aliased AWA.Blogs.Modules.Blog_Module;
      Mail_Module       : aliased AWA.Mail.Modules.Mail_Module;
      Storage_Module    : aliased AWA.Storages.Modules.Storage_Module;
      Image_Module      : aliased AWA.Images.Modules.Image_Module;
      Question_Module   : aliased AWA.Questions.Modules.Question_Module;

      Microblog_Module  : aliased Atlas.Microblog.Modules.Microblog_Module;
--      XXX_Module    : aliased Atlas.XXX.Module.XXX_Module;
   end record;

end Atlas.Applications;

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

with ASF.Servlets.Faces;
with ASF.Servlets.Files;
with ASF.Servlets.Ajax;
with ASF.Filters.Dump;
with ASF.Servlets.Measures;

with ASF.Security.Servlets;
with ASF.Converters.Sizes;

with AWA.Users.Servlets;
with AWA.Users.Modules;
with AWA.Mail.Modules;
with AWA.Blogs.Modules;
with AWA.Applications;
with AWA.Workspaces.Modules;
with AWA.Storages.Modules;
with AWA.Images.Modules;
with AWA.Questions.Modules;
with AWA.Votes.Modules;
with AWA.Services.Filters;
with AWA.Converters.Dates;

with Atlas.Microblog.Modules;
package Atlas.Applications is

   CONFIG_PATH  : constant String := "/atlas";
   CONTEXT_PATH : constant String := "/atlas";

   ATLAS_NS_URI : aliased constant String := "http://code.google.com/p/ada-awa/atlas";

   --  Given an Email address, return the Gravatar link to the user image.
   --  (See http://en.gravatar.com/site/implement/hash/ and
   --  http://en.gravatar.com/site/implement/images/)
   function Get_Gravatar_Link (Email : in String) return String;

   --  EL function to convert an Email address to a Gravatar image.
   function To_Gravatar_Link (Email : in Util.Beans.Objects.Object)
                              return Util.Beans.Objects.Object;

   type Application is new AWA.Applications.Application with private;
   type Application_Access is access all Application'Class;

   --  Initialize the application.
   procedure Initialize (App : in Application_Access);

   --  Initialize the ASF components provided by the application.
   --  This procedure is called by Initialize.
   --  It should register the component factories used by the application.
   overriding
   procedure Initialize_Components (App : in out Application);

   --  Initialize the servlets provided by the application.
   --  This procedure is called by Initialize.
   --  It should register the application servlets.
   overriding
   procedure Initialize_Servlets (App : in out Application);

   --  Initialize the filters provided by the application.
   --  This procedure is called by Initialize.
   --  It should register the application filters.
   overriding
   procedure Initialize_Filters (App : in out Application);

   --  Initialize the AWA modules provided by the application.
   --  This procedure is called by Initialize.
   --  It should register the modules used by the application.
   overriding
   procedure Initialize_Modules (App : in out Application);

private

   type Application is new AWA.Applications.Application with record
      Self              : Application_Access;
      --  Application servlets and filters (add new servlet and filter instances here).
      Faces             : aliased ASF.Servlets.Faces.Faces_Servlet;
      Ajax              : aliased ASF.Servlets.Ajax.Ajax_Servlet;
      Files             : aliased ASF.Servlets.Files.File_Servlet;
      Dump              : aliased ASF.Filters.Dump.Dump_Filter;
      Service_Filter    : aliased AWA.Services.Filters.Service_Filter;
      Measures          : aliased ASF.Servlets.Measures.Measure_Servlet;

      --  Authentication servlet and filter.
      Auth              : aliased ASF.Security.Servlets.Request_Auth_Servlet;
      Verify_Auth       : aliased AWA.Users.Servlets.Verify_Auth_Servlet;

      --  Converters shared by web requests.
      Rel_Date_Converter : aliased AWA.Converters.Dates.Relative_Date_Converter;
      Size_Converter     : aliased ASF.Converters.Sizes.Size_Converter;

      --  The application modules.
      User_Module       : aliased AWA.Users.Modules.User_Module;
      Workspace_Module  : aliased AWA.Workspaces.Modules.Workspace_Module;
      Blog_Module       : aliased AWA.Blogs.Modules.Blog_Module;
      Mail_Module       : aliased AWA.Mail.Modules.Mail_Module;
      Storage_Module    : aliased AWA.Storages.Modules.Storage_Module;
      Image_Module      : aliased AWA.Images.Modules.Image_Module;
      Vote_Module       : aliased AWA.Votes.Modules.Vote_Module;
      Question_Module   : aliased AWA.Questions.Modules.Question_Module;

      Microblog_Module  : aliased Atlas.Microblog.Modules.Microblog_Module;
--      XXX_Module    : aliased Atlas.XXX.Module.XXX_Module;
   end record;

end Atlas.Applications;

Add the vote plugin

Add the vote plugin


--  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.Types;

with Orka.Containers.Bounded_Vectors;

package Orka.glTF.Meshes is
   pragma Preelaborate;

   subtype Primitive_Mode is GL.Types.Connection_Mode
     range GL.Types.Points .. GL.Types.Triangle_Strip;

   type Attribute_Kind is (Position, Normal, Texcoord_0);

   type Attribute_Array is array (Attribute_Kind) of Natural;

   type Primitive is record
      Attributes : Attribute_Array;
      Indices    : Natural_Optional;
      Material   : Natural_Optional;
      Mode       : Primitive_Mode;
   end record;

   type Mesh is record
      --  Orka.Resources.Models.glTF can handle only one primitive per mesh
      Primitives : Primitive;
      Name       : Name_Strings.Bounded_String;
   end record;

   package Mesh_Vectors is new Orka.Containers.Bounded_Vectors (Natural, Mesh);

   function Get_Meshes
     (Meshes : Types.JSON_Value) return Mesh_Vectors.Vector;

end Orka.glTF.Meshes;

--  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.Types;

with Orka.Containers.Bounded_Vectors;

package Orka.glTF.Meshes is
   pragma Preelaborate;

   subtype Primitive_Mode is GL.Types.Connection_Mode
     range GL.Types.Points .. GL.Types.Triangle_Strip;

   type Attribute_Kind is (Position, Normal, Texcoord_0);
   --  TODO Other kinds: Tangent, Texcoord_1, Color_0, Joints_0, Weights_0

   type Attribute_Array is array (Attribute_Kind) of Natural;
   --  FIXME Support more attribute kinds and use Boolean to indicate whether it is used

   type Primitive is record
      Attributes : Attribute_Array;
      Indices    : Natural_Optional;
      Material   : Natural_Optional;
      Mode       : Primitive_Mode;
   end record;

   type Mesh is record
      --  Orka.Resources.Models.glTF can handle only one primitive per mesh
      Primitives : Primitive;
      Name       : Name_Strings.Bounded_String;
   end record;

   package Mesh_Vectors is new Orka.Containers.Bounded_Vectors (Natural, Mesh);

   function Get_Meshes
     (Meshes : Types.JSON_Value) return Mesh_Vectors.Vector;

end Orka.glTF.Meshes;

gltf: Add some TODOs/FIXMEs to package Orka.glTF.Meshes

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


-----------------------------------------------------------------------
--  util-concurrent-fifos -- Concurrent Fifo Queues
--  Copyright (C) 2012, 2014, 2015, 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.Unchecked_Deallocation;
package body Util.Concurrent.Fifos is

   --  ------------------------------
   --  Put the element in the queue.
   --  ------------------------------
   procedure Enqueue (Into    : in out Fifo;
                      Item    : in Element_Type;
                      Wait    : in Duration := FOREVER) is
   begin
      if Wait < 0.0 then
         Into.Buffer.Enqueue (Item);
      else
         select
            Into.Buffer.Enqueue (Item);
         or
            delay Wait;
            raise Timeout;
         end select;
      end if;
   end Enqueue;

   --  ------------------------------
   --  Get an element from the queue.
   --  Wait until one element gets available.
   --  ------------------------------
   procedure Dequeue (From    : in out Fifo;
                      Item    : out Element_Type;
                      Wait    : in Duration := FOREVER) is
   begin
      if Wait < 0.0 then
         From.Buffer.Dequeue (Item);
      else
         select
            From.Buffer.Dequeue (Item);
         or
            delay Wait;
            raise Timeout;
         end select;
      end if;
   end Dequeue;

   --  ------------------------------
   --  Get the number of elements in the queue.
   --  ------------------------------
   function Get_Count (From : in Fifo) return Natural is
   begin
      return From.Buffer.Get_Count;
   end Get_Count;

   --  ------------------------------
   --  Set the queue size.
   --  ------------------------------
   procedure Set_Size (Into : in out Fifo;
                       Capacity : in Positive) is
   begin
      Into.Buffer.Set_Size (Capacity);
   end Set_Size;

   --  ------------------------------
   --  Initializes the queue.
   --  ------------------------------
   overriding
   procedure Initialize (Object : in out Fifo) is
   begin
      Object.Buffer.Set_Size (Default_Size);
   end Initialize;

   --  ------------------------------
   --  Release the queue elements.
   --  ------------------------------
   overriding
   procedure Finalize (Object : in out Fifo) is
   begin
      if Clear_On_Dequeue then
         while Object.Get_Count > 0 loop
            declare
               Unused : Element_Type;
            begin
               Object.Dequeue (Unused);
            end;
         end loop;
      end if;
      Object.Buffer.Set_Size (0);
   end Finalize;

   --  Queue of objects.
   protected body Protected_Fifo is

      --  ------------------------------
      --  Put the element in the queue.
      --  If the queue is full, wait until some room is available.
      --  ------------------------------
      entry Enqueue (Item : in Element_Type) when Count < Elements'Length is
      begin
         Elements (Last) := Item;
         Last := Last + 1;
         if Last > Elements'Last then
            if Clear_On_Dequeue then
               Last := Elements'First + 1;
            else
               Last := Elements'First;
            end if;
         end if;
         Count := Count + 1;
      end Enqueue;

      --  ------------------------------
      --  Get an element from the queue.
      --  Wait until one element gets available.
      --  ------------------------------
      entry Dequeue (Item : out Element_Type) when Count > 0 is
      begin
         Count := Count - 1;
         Item := Elements (First);

         --  For the clear on dequeue mode, erase the queue element.
         --  If the element holds some storage or a reference, this gets cleared here.
         --  The element used to clear is at index 0 (which does not exist if Clear_On_Dequeue
         --  is false).  There is no overhead when this is not used
         --  (ie, instantiation/compile time flag).
         if Clear_On_Dequeue then
            Elements (First) := Elements (0);
         end if;
         First := First + 1;
         if First > Elements'Last then
            if Clear_On_Dequeue then
               First := Elements'First + 1;
            else
               First := Elements'First;
            end if;
         end if;
      end Dequeue;

      --  ------------------------------
      --  Get the number of elements in the queue.
      --  ------------------------------
      function Get_Count return Natural is
      begin
         return Count;
      end Get_Count;

      --  ------------------------------
      --  Set the queue size.
      --  ------------------------------
      procedure Set_Size (Capacity : in Natural) is
         procedure Free is new Ada.Unchecked_Deallocation (Element_Array, Element_Array_Access);
         First_Pos : Natural := 1;
      begin
         if Clear_On_Dequeue then
            First_Pos := 0;
         end if;
         if Capacity = 0 then
            Free (Elements);
         elsif Elements = null then
            Elements := new Element_Array (First_Pos .. Capacity);
         else
            declare
               New_Array : constant Element_Array_Access
                 := new Element_Array (First_Pos .. Capacity);
            begin
               if Capacity > Elements'Length then
                  New_Array (First_Pos .. Elements'Last) := Elements (First_Pos .. Elements'Last);
               else
                  New_Array (First_Pos .. Capacity) := Elements (First_Pos .. Capacity);
               end if;

               Free (Elements);
               Elements := New_Array;
            end;
         end if;
      end Set_Size;

   end Protected_Fifo;

end Util.Concurrent.Fifos;

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

with Ada.Unchecked_Deallocation;
package body Util.Concurrent.Fifos is

   --  ------------------------------
   --  Put the element in the queue.
   --  ------------------------------
   procedure Enqueue (Into    : in out Fifo;
                      Item    : in Element_Type;
                      Wait    : in Duration := FOREVER) is
   begin
      if Wait < 0.0 then
         Into.Buffer.Enqueue (Item);
      else
         select
            Into.Buffer.Enqueue (Item);
         or
            delay Wait;
            raise Timeout;
         end select;
      end if;
   end Enqueue;

   --  ------------------------------
   --  Get an element from the queue.
   --  Wait until one element gets available.
   --  ------------------------------
   procedure Dequeue (From    : in out Fifo;
                      Item    : out Element_Type;
                      Wait    : in Duration := FOREVER) is
   begin
      if Wait < 0.0 then
         From.Buffer.Dequeue (Item);
      else
         select
            From.Buffer.Dequeue (Item);
         or
            delay Wait;
            raise Timeout;
         end select;
      end if;
   end Dequeue;

   --  ------------------------------
   --  Wait for the fifo to become empty.
   --  ------------------------------
   procedure Wait_Empty (From : in out Fifo) is
   begin
      From.Buffer.Wait_Empty;
   end Wait_Empty;

   --  ------------------------------
   --  Get the number of elements in the queue.
   --  ------------------------------
   function Get_Count (From : in Fifo) return Natural is
   begin
      return From.Buffer.Get_Count;
   end Get_Count;

   --  ------------------------------
   --  Set the queue size.
   --  ------------------------------
   procedure Set_Size (Into : in out Fifo;
                       Capacity : in Positive) is
   begin
      Into.Buffer.Set_Size (Capacity);
   end Set_Size;

   --  ------------------------------
   --  Initializes the queue.
   --  ------------------------------
   overriding
   procedure Initialize (Object : in out Fifo) is
   begin
      Object.Buffer.Set_Size (Default_Size);
   end Initialize;

   --  ------------------------------
   --  Release the queue elements.
   --  ------------------------------
   overriding
   procedure Finalize (Object : in out Fifo) is
   begin
      if Clear_On_Dequeue then
         while Object.Get_Count > 0 loop
            declare
               Unused : Element_Type;
            begin
               Object.Dequeue (Unused);
            end;
         end loop;
      end if;
      Object.Buffer.Set_Size (0);
   end Finalize;

   --  Queue of objects.
   protected body Protected_Fifo is

      --  ------------------------------
      --  Put the element in the queue.
      --  If the queue is full, wait until some room is available.
      --  ------------------------------
      entry Enqueue (Item : in Element_Type) when Count < Elements'Length - (if Clear_On_Dequeue then 1 else 0) is
      begin
         Elements (Last) := Item;
         Last := Last + 1;
         if Last > Elements'Last then
            if Clear_On_Dequeue then
               Last := Elements'First + 1;
            else
               Last := Elements'First;
            end if;
         end if;
         Count := Count + 1;
      end Enqueue;

      --  ------------------------------
      --  Get an element from the queue.
      --  Wait until one element gets available.
      --  ------------------------------
      entry Dequeue (Item : out Element_Type) when Count > 0 is
      begin
         Count := Count - 1;
         Item := Elements (First);

         --  For the clear on dequeue mode, erase the queue element.
         --  If the element holds some storage or a reference, this gets cleared here.
         --  The element used to clear is at index 0 (which does not exist if Clear_On_Dequeue
         --  is false).  There is no overhead when this is not used
         --  (ie, instantiation/compile time flag).
         if Clear_On_Dequeue then
            Elements (First) := Elements (0);
         end if;
         First := First + 1;
         if First > Elements'Last then
            if Clear_On_Dequeue then
               First := Elements'First + 1;
            else
               First := Elements'First;
            end if;
         end if;
      end Dequeue;

      --  ------------------------------
      --  Wait for the queue to become empty.
      --  ------------------------------
      entry Wait_Empty when Count = 0 is
      begin
         null;
      end Wait_Empty;

      --  ------------------------------
      --  Get the number of elements in the queue.
      --  ------------------------------
      function Get_Count return Natural is
      begin
         return Count;
      end Get_Count;

      --  ------------------------------
      --  Set the queue size.
      --  ------------------------------
      procedure Set_Size (Capacity : in Natural) is
         procedure Free is new Ada.Unchecked_Deallocation (Element_Array, Element_Array_Access);
         First_Pos : Natural := 1;
      begin
         if Clear_On_Dequeue then
            First_Pos := 0;
         end if;
         if Capacity = 0 then
            Free (Elements);
         elsif Elements = null then
            Elements := new Element_Array (First_Pos .. Capacity);
         else
            declare
               New_Array : constant Element_Array_Access
                 := new Element_Array (First_Pos .. Capacity);
            begin
               if Capacity > Elements'Length then
                  New_Array (First_Pos .. Elements'Last) := Elements (First_Pos .. Elements'Last);
               else
                  New_Array (First_Pos .. Capacity) := Elements (First_Pos .. Capacity);
               end if;

               Free (Elements);
               Elements := New_Array;
            end;
         end if;
      end Set_Size;

   end Protected_Fifo;

end Util.Concurrent.Fifos;

Implement Wait_Empty operation and fix Enqueue when Clear_On_Dequeue is used


-----------------------------------------------------------------------
--  mat-symbols-targets - Symbol files management
--  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 Bfd.Symbols;
with Bfd.Files;
package MAT.Symbols.Targets is

   type Target_Symbols is limited record
      File    : Bfd.Files.File_Type;
      Symbols : Bfd.Symbols.Symbol_Table;
   end record;

   --  Open the binary and load the symbols from that file.
   procedure Open (Symbols : in out Target_Symbols;
                   Path    : in String);

end MAT.Symbols.Targets;

-----------------------------------------------------------------------
--  mat-symbols-targets - Symbol files management
--  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 Bfd.Symbols;
with Bfd.Files;

with MAT.Types;
package MAT.Symbols.Targets is

   type Target_Symbols is limited record
      File    : Bfd.Files.File_Type;
      Symbols : Bfd.Symbols.Symbol_Table;
   end record;

   --  Open the binary and load the symbols from that file.
   procedure Open (Symbols : in out Target_Symbols;
                   Path    : in String);

   --  Find the nearest source file and line for the given address.
   procedure Find_Nearest_Line (Symbols : in Target_Symbols;
                                Addr    : in MAT.Types.Target_Addr;
                                Name    : out Ada.Strings.Unbounded.Unbounded_String;
                                Func    : out Ada.Strings.Unbounded.Unbounded_String;
                                Line    : out Natural);

end MAT.Symbols.Targets;

Declare the Find_Nearest_Line procedure

Declare the Find_Nearest_Line procedure