--  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 Glfw.Errors;
with Glfw.Windows.Context;
with Glfw.Windows.Hints;

with Orka.Inputs.GLFW;
with Orka.Logging;

with GL.Context;
with GL.Viewports;

package body Orka.Windows.GLFW is

   use all type Orka.Logging.Source;
   use all type Orka.Logging.Severity;
   use Orka.Logging;

   package Messages is new Orka.Logging.Messages (Window_System);

   procedure Print_Error (Code : Standard.Glfw.Errors.Kind; Description : String) is
   begin
      Messages.Log (Error, "GLFW " & Code'Image & ": " & Trim (Description));
   end Print_Error;

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

   overriding
   procedure Finalize (Object : in out GLFW_Context) is
   begin
      if Object.Flags.Debug then
         Messages.Log (Debug, "Shutting down GLFW");
      end if;

      Standard.Glfw.Shutdown;
   end Finalize;

   overriding
   procedure Enable (Object : in out GLFW_Context; Subject : Contexts.Feature) is
   begin
      Contexts.Enable (Object.Features, Subject);
   end Enable;

   overriding
   function Enabled (Object : GLFW_Context; Subject : Contexts.Feature) return Boolean
     is (Contexts.Enabled (Object.Features, Subject));

   overriding
   function Is_Current (Object : GLFW_Context) return Boolean is
   begin
      raise GL.Feature_Not_Supported_Exception;
      return True;
   end Is_Current;

   overriding
   procedure Make_Current (Object : GLFW_Context) is
   begin
      raise GL.Feature_Not_Supported_Exception;
   end Make_Current;

   overriding
   procedure Make_Current
     (Object : GLFW_Context;
      Window : in out Orka.Windows.Window'Class)
   is
      Reference : constant Standard.Glfw.Windows.Window_Reference
        := Standard.Glfw.Windows.Window (Window)'Access;
   begin
      Standard.Glfw.Windows.Context.Make_Current (Reference);
   end Make_Current;

   overriding
   procedure Make_Not_Current (Object : GLFW_Context) is
   begin
      Standard.Glfw.Windows.Context.Make_Current (null);
      --  TODO Make sure Object is current on calling task
   end Make_Not_Current;

   overriding
   function Version (Object : GLFW_Context) return Contexts.Context_Version is
   begin
      return
        (Major => GL.Context.Major_Version,
         Minor => GL.Context.Minor_Version);
   end Version;

   overriding
   function Flags (Object : GLFW_Context) return Contexts.Context_Flags is
      Flags : constant GL.Context.Context_Flags := GL.Context.Flags;

      Result : Contexts.Context_Flags;
   begin
      pragma Assert (Flags.Forward_Compatible);

      Result.Debug    := Flags.Debug;
      Result.Robust   := Flags.Robust_Access;
      Result.No_Error := Flags.No_Error;

      return Result;
   end Flags;

   overriding
   function Create_Context
     (Version : Contexts.Context_Version;
      Flags   : Contexts.Context_Flags := (others => False)) return GLFW_Context
   is
      package Context_Hints renames Standard.Glfw.Windows.Context;
   begin
      --  Initialize GLFW
      Standard.Glfw.Errors.Set_Callback (Print_Error'Access);
      Standard.Glfw.Init;

      --  Initialize OpenGL context
      Standard.Glfw.Windows.Hints.Set_Minimum_OpenGL_Version (Version.Major, Version.Minor);
      Standard.Glfw.Windows.Hints.Set_Forward_Compat (True);
      Standard.Glfw.Windows.Hints.Set_Client_API (Context_Hints.OpenGL);
      Standard.Glfw.Windows.Hints.Set_Profile (Context_Hints.Core_Profile);
      Standard.Glfw.Windows.Hints.Set_Debug_Context (Flags.Debug);
      Standard.Glfw.Windows.Hints.Set_Robustness
        (if Flags.Robust then
           Context_Hints.Lose_Context_On_Reset
         else
           Context_Hints.No_Robustness);
--      Standard.Glfw.Windows.Hints.Set_No_Error_Context (Flags.No_Error);

      return (Ada.Finalization.Limited_Controlled with
        Version  => Version,
        Flags    => Flags,
        Features => <>);
   end Create_Context;

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

   overriding
   function Create_Window
     (Context            : Contexts.Surface_Context'Class;
      Width, Height      : Positive;
      Title              : String  := "";
      Samples            : Natural := 0;
      Visible, Resizable : Boolean := True;
      Transparent        : Boolean := False) return GLFW_Window
   is
      package Windows renames Standard.Glfw.Windows;
   begin
      return Result : GLFW_Window := GLFW_Window'(Windows.Window
        with Input => Inputs.GLFW.Create_Pointer_Input, Finalized => False, others => <>)
      do
         declare
            Reference : constant Windows.Window_Reference
              := Windows.Window (Window'Class (Result))'Access;
         begin
            Windows.Hints.Set_Visible (Visible);
            Windows.Hints.Set_Resizable (Resizable);
            Windows.Hints.Set_Samples (Samples);
            Windows.Hints.Set_Transparent_Framebuffer (Transparent);

            Reference.Init (Standard.Glfw.Size (Width), Standard.Glfw.Size (Height), Title);

            Inputs.GLFW.GLFW_Pointer_Input (Result.Input.all).Set_Window (Reference);

            declare
               Width, Height : Standard.Glfw.Size;
            begin
               Reference.Get_Framebuffer_Size (Width, Height);
               Result.Framebuffer_Size_Changed (Natural (Width), Natural (Height));

               Messages.Log (Debug, "Created GLFW window and GL context");
               Messages.Log (Debug, "  size:      " &
                 Trim (Width'Image) & " × " & Trim (Height'Image));
               Messages.Log (Debug, "  visible:     " & (if Visible then "yes" else "no"));
               Messages.Log (Debug, "  resizable:   " & (if Resizable then "yes" else "no"));
               Messages.Log (Debug, "  transparent: " & (if Transparent then "yes" else "no"));
            end;

            --  Callbacks
            Reference.Enable_Callback (Windows.Callbacks.Close);
            Reference.Enable_Callback (Windows.Callbacks.Mouse_Button);
            Reference.Enable_Callback (Windows.Callbacks.Mouse_Position);
            Reference.Enable_Callback (Windows.Callbacks.Mouse_Scroll);
            Reference.Enable_Callback (Windows.Callbacks.Key);
            Reference.Enable_Callback (Windows.Callbacks.Framebuffer_Size);

            Standard.Glfw.Windows.Context.Make_Current (Reference);

            Messages.Log (Debug, "  context:");
            Messages.Log (Debug, "    flags:    " & Orka.Contexts.Image (Context.Flags));
            Messages.Log (Debug, "    version:  " & GL.Context.Version_String);
            Messages.Log (Debug, "    renderer: " & GL.Context.Renderer);

            GL.Viewports.Set_Clipping (GL.Viewports.Lower_Left, GL.Viewports.Zero_To_One);
            Result.Vertex_Array.Create;
         end;
      end return;
   end Create_Window;

   overriding
   procedure Finalize (Object : in out GLFW_Window) is
   begin
      if not Object.Finalized then
         Messages.Log (Debug, "Closing GLFW window");

         Object.Vertex_Array.Delete;

         Standard.Glfw.Windows.Context.Make_Current (null);
         --  FIXME Requires context to be current => ask render task to release context

         Object.Destroy;
         Object.Finalized := True;
      end if;
   end Finalize;

   overriding
   function Pointer_Input
     (Object : GLFW_Window) return Inputs.Pointers.Pointer_Input_Ptr
   is (Object.Input);

   overriding
   function Width (Object : GLFW_Window) return Positive is (Object.Width);

   overriding
   function Height (Object : GLFW_Window) return Positive is (Object.Height);

   overriding
   procedure Set_Title (Object : in out GLFW_Window; Value : String) is
   begin
      Standard.Glfw.Windows.Window (Object)'Access.Set_Title (Value);
   end Set_Title;

   overriding
   procedure Close (Object : in out GLFW_Window) is
   begin
      Object.Set_Should_Close (True);
   end Close;

   overriding
   function Should_Close (Object : GLFW_Window) return Boolean is
   begin
      return Standard.Glfw.Windows.Window (Object)'Access.Should_Close;
   end Should_Close;

   overriding
   procedure Process_Input (Object : in out GLFW_Window) is
      Prev_Position_X : constant GL.Types.Double := Object.Position_X;
      Prev_Position_Y : constant GL.Types.Double := Object.Position_Y;

      use type GL.Types.Double;
   begin
      Object.Scroll_X := 0.0;
      Object.Scroll_Y := 0.0;

      Standard.Glfw.Input.Poll_Events;

      --  Update position of mouse
      Inputs.GLFW.GLFW_Pointer_Input (Object.Input.all).Set_Position
        (Object.Position_X, Object.Position_Y);

      --  Keep track of Locked transitioned to True
      if Object.Input.Locked then
         Object.Got_Locked := Object.Got_Locked or not Object.Last_Locked;
      else
         Object.Got_Locked := False;
      end if;
      Object.Last_Locked := Object.Input.Locked;

      if Object.Got_Locked and then
        (Object.Position_X /= Prev_Position_X or Object.Position_Y /= Prev_Position_Y)
      then
         Object.Got_Locked := False;

         --  GLFW bug: Update position of mouse again to reset delta to 0.0
         Inputs.GLFW.GLFW_Pointer_Input (Object.Input.all).Set_Position
           (Object.Position_X, Object.Position_Y);
      end if;

      --  Update scroll offset of mouse
      Inputs.GLFW.GLFW_Pointer_Input (Object.Input.all).Set_Scroll_Offset
        (Object.Scroll_X, Object.Scroll_Y);
   end Process_Input;

   overriding
   procedure Swap_Buffers (Object : in out GLFW_Window) is
   begin
      Standard.Glfw.Windows.Context.Swap_Buffers (Object'Access);
   end Swap_Buffers;

   overriding
   procedure Enable_Vertical_Sync (Object : in out GLFW_Window; Enable : Boolean) is
   begin
      Standard.Glfw.Windows.Context.Set_Swap_Interval (if Enable then 1 else 0);
   end Enable_Vertical_Sync;

   overriding
   procedure Close_Requested (Object : not null access GLFW_Window) is
   begin
      --  TODO Call Object.Set_Should_Close (False); if certain conditions are not met
      null;
   end Close_Requested;

   overriding
   procedure Key_Changed
     (Object   : not null access GLFW_Window;
      Key      : Standard.Glfw.Input.Keys.Key;
      Scancode : Standard.Glfw.Input.Keys.Scancode;
      Action   : Standard.Glfw.Input.Keys.Action;
      Mods     : Standard.Glfw.Input.Keys.Modifiers)
   is
      use Standard.Glfw.Input.Keys;
   begin
      if Key = Escape and Action = Press then
         Object.Set_Should_Close (True);
      end if;
      --  TODO Add Button_Input object
   end Key_Changed;

   overriding
   procedure Mouse_Position_Changed
     (Object : not null access GLFW_Window;
      X, Y   : Standard.Glfw.Input.Mouse.Coordinate) is
   begin
      Object.Position_X := GL.Types.Double (X);
      Object.Position_Y := GL.Types.Double (Y);
   end Mouse_Position_Changed;

   overriding
   procedure Mouse_Scrolled
     (Object : not null access GLFW_Window;
      X, Y   : Standard.Glfw.Input.Mouse.Scroll_Offset)
   is
      use type GL.Types.Double;
   begin
      --  Accumulate the offset because the callback can be called
      --  multiple times
      Object.Scroll_X := Object.Scroll_X + GL.Types.Double (X);
      Object.Scroll_Y := Object.Scroll_Y + GL.Types.Double (Y);
   end Mouse_Scrolled;

   overriding
   procedure Mouse_Button_Changed
     (Object  : not null access GLFW_Window;
      Button  : Standard.Glfw.Input.Mouse.Button;
      State   : Standard.Glfw.Input.Button_State;
      Mods    : Standard.Glfw.Input.Keys.Modifiers) is
   begin
      Inputs.GLFW.GLFW_Pointer_Input (Object.Input.all).Set_Button_State (Button, State);
   end Mouse_Button_Changed;

   overriding
   procedure Framebuffer_Size_Changed
     (Object : not null access GLFW_Window;
      Width, Height : Natural) is
   begin
      Object.Width  := Width;
      Object.Height := Height;
   end Framebuffer_Size_Changed;

end Orka.Windows.GLFW;

glfw: Align text of window size in log messages with other text

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


--  This file is covered by the Internet Software Consortium (ISC) License
--  Reference: ../License.txt

package Definitions is

   pragma Pure;

   raven_version_major : constant String := "1";
   raven_version_minor : constant String := "21";
   copyright_years     : constant String := "2015-2019";

   raven_tool        : constant String := "ravenadm";
   variant_standard  : constant String := "standard";
   contact_nobody    : constant String := "nobody";
   contact_automaton : constant String := "automaton";
   dlgroup_main      : constant String := "main";
   dlgroup_none      : constant String := "none";
   options_none      : constant String := "none";
   options_all       : constant String := "all";
   broken_all        : constant String := "all";
   boolean_yes       : constant String := "yes";
   homepage_none     : constant String := "none";
   spkg_complete     : constant String := "complete";
   spkg_docs         : constant String := "docs";
   spkg_examples     : constant String := "examples";
   ports_default     : constant String := "floating";
   default_ssl       : constant String := "libressl";
   default_mysql     : constant String := "oracle-5.7";
   default_lua       : constant String := "5.3";
   default_perl      : constant String := "5.28";
   default_pgsql     : constant String := "10";
   default_php       : constant String := "7.2";
   default_python3   : constant String := "3.7";
   default_ruby      : constant String := "2.5";
   default_tcltk     : constant String := "8.6";
   default_firebird  : constant String := "2.5";
   default_compiler  : constant String := "gcc8";
   compiler_version  : constant String := "8.2.0";
   previous_compiler : constant String := "7.3.0";
   binutils_version  : constant String := "2.31.1";
   previous_binutils : constant String := "2.30";
   arc_ext           : constant String := ".tzst";
   jobs_per_cpu      : constant := 2;

   type supported_opsys is (dragonfly, freebsd, netbsd, openbsd, sunos, linux, macos);
   type supported_arch  is (x86_64, i386, aarch64);

   type cpu_range is range 1 .. 64;
   type scanners  is range cpu_range'First .. cpu_range'Last;
   type builders  is range cpu_range'First .. cpu_range'Last * jobs_per_cpu;
   type count_type is (total, success, failure, ignored, skipped);

   --  Modify following with post-patch sed accordingly
   platform_type  : constant supported_opsys := dragonfly;
   host_localbase : constant String := "/raven";
   raven_var      : constant String := "/var/ravenports";
   host_pkg8      : constant String := host_localbase & "/sbin/pkg-static";
   ravenexec      : constant String := host_localbase & "/libexec/ravenexec";

end Definitions;

--  This file is covered by the Internet Software Consortium (ISC) License
--  Reference: ../License.txt

package Definitions is

   pragma Pure;

   raven_version_major : constant String := "1";
   raven_version_minor : constant String := "22";
   copyright_years     : constant String := "2015-2019";

   raven_tool        : constant String := "ravenadm";
   variant_standard  : constant String := "standard";
   contact_nobody    : constant String := "nobody";
   contact_automaton : constant String := "automaton";
   dlgroup_main      : constant String := "main";
   dlgroup_none      : constant String := "none";
   options_none      : constant String := "none";
   options_all       : constant String := "all";
   broken_all        : constant String := "all";
   boolean_yes       : constant String := "yes";
   homepage_none     : constant String := "none";
   spkg_complete     : constant String := "complete";
   spkg_docs         : constant String := "docs";
   spkg_examples     : constant String := "examples";
   ports_default     : constant String := "floating";
   default_ssl       : constant String := "libressl";
   default_mysql     : constant String := "oracle-5.7";
   default_lua       : constant String := "5.3";
   default_perl      : constant String := "5.28";
   default_pgsql     : constant String := "10";
   default_php       : constant String := "7.2";
   default_python3   : constant String := "3.7";
   default_ruby      : constant String := "2.5";
   default_tcltk     : constant String := "8.6";
   default_firebird  : constant String := "2.5";
   default_compiler  : constant String := "gcc8";
   compiler_version  : constant String := "8.2.0";
   previous_compiler : constant String := "7.3.0";
   binutils_version  : constant String := "2.31.1";
   previous_binutils : constant String := "2.30";
   arc_ext           : constant String := ".tzst";
   jobs_per_cpu      : constant := 2;

   type supported_opsys is (dragonfly, freebsd, netbsd, openbsd, sunos, linux, macos);
   type supported_arch  is (x86_64, i386, aarch64);

   type cpu_range is range 1 .. 64;
   type scanners  is range cpu_range'First .. cpu_range'Last;
   type builders  is range cpu_range'First .. cpu_range'Last * jobs_per_cpu;
   type count_type is (total, success, failure, ignored, skipped);

   --  Modify following with post-patch sed accordingly
   platform_type  : constant supported_opsys := dragonfly;
   host_localbase : constant String := "/raven";
   raven_var      : constant String := "/var/ravenports";
   host_pkg8      : constant String := host_localbase & "/sbin/pkg-static";
   ravenexec      : constant String := host_localbase & "/libexec/ravenexec";

end Definitions;

Bump version for release

Bump version for release


--  This file is covered by the Internet Software Consortium (ISC) License
--  Reference: ../License.txt

package Definitions is

   pragma Pure;

   raven_version_major : constant String := "1";
   raven_version_minor : constant String := "53";
   copyright_years     : constant String := "2015-2020";

   raven_tool        : constant String := "ravenadm";
   variant_standard  : constant String := "standard";
   contact_nobody    : constant String := "nobody";
   contact_automaton : constant String := "automaton";
   dlgroup_main      : constant String := "main";
   dlgroup_none      : constant String := "none";
   options_none      : constant String := "none";
   options_all       : constant String := "all";
   broken_all        : constant String := "all";
   boolean_yes       : constant String := "yes";
   homepage_none     : constant String := "none";
   spkg_complete     : constant String := "complete";
   spkg_docs         : constant String := "docs";
   spkg_examples     : constant String := "examples";
   spkg_nls          : constant String := "nls";
   ports_default     : constant String := "floating";
   default_ssl       : constant String := "libressl";
   default_mysql     : constant String := "oracle-8.0";
   default_lua       : constant String := "5.3";
   default_perl      : constant String := "5.30";
   default_pgsql     : constant String := "12";
   default_php       : constant String := "7.4";
   default_python3   : constant String := "3.8";
   default_ruby      : constant String := "2.7";
   default_tcltk     : constant String := "8.6";
   default_firebird  : constant String := "2.5";
   default_binutils  : constant String := "binutils:ravensys";
   default_compiler  : constant String := "gcc9";
   previous_default  : constant String := "gcc9";
   compiler_version  : constant String := "9.3.0";
   previous_compiler : constant String := "9.2.0";
   binutils_version  : constant String := "2.34";
   previous_binutils : constant String := "2.33.1";
   arc_ext           : constant String := ".tzst";
   jobs_per_cpu      : constant := 2;
   task_stack_limit  : constant := 10_000_000;

   type supported_opsys is (dragonfly, freebsd, netbsd, openbsd, sunos, linux, macos);
   type supported_arch  is (x86_64, i386, aarch64);

   type cpu_range is range 1 .. 64;
   type scanners  is range cpu_range'First .. cpu_range'Last;
   type builders  is range cpu_range'First .. cpu_range'Last * jobs_per_cpu;
   type count_type is (total, success, failure, ignored, skipped);

   --  Modify following with post-patch sed accordingly
   platform_type  : constant supported_opsys := dragonfly;
   host_localbase : constant String := "/raven";
   raven_var      : constant String := "/var/ravenports";
   host_pkg8      : constant String := host_localbase & "/sbin/ravensw";
   ravenexec      : constant String := host_localbase & "/libexec/ravenexec";

end Definitions;

--  This file is covered by the Internet Software Consortium (ISC) License
--  Reference: ../License.txt

package Definitions is

   pragma Pure;

   raven_version_major : constant String := "1";
   raven_version_minor : constant String := "54";
   copyright_years     : constant String := "2015-2020";

   raven_tool        : constant String := "ravenadm";
   variant_standard  : constant String := "standard";
   contact_nobody    : constant String := "nobody";
   contact_automaton : constant String := "automaton";
   dlgroup_main      : constant String := "main";
   dlgroup_none      : constant String := "none";
   options_none      : constant String := "none";
   options_all       : constant String := "all";
   broken_all        : constant String := "all";
   boolean_yes       : constant String := "yes";
   homepage_none     : constant String := "none";
   spkg_complete     : constant String := "complete";
   spkg_docs         : constant String := "docs";
   spkg_examples     : constant String := "examples";
   spkg_nls          : constant String := "nls";
   ports_default     : constant String := "floating";
   default_ssl       : constant String := "libressl";
   default_mysql     : constant String := "oracle-8.0";
   default_lua       : constant String := "5.3";
   default_perl      : constant String := "5.30";
   default_pgsql     : constant String := "12";
   default_php       : constant String := "7.4";
   default_python3   : constant String := "3.8";
   default_ruby      : constant String := "2.7";
   default_tcltk     : constant String := "8.6";
   default_firebird  : constant String := "2.5";
   default_binutils  : constant String := "binutils:ravensys";
   default_compiler  : constant String := "gcc9";
   previous_default  : constant String := "gcc9";
   compiler_version  : constant String := "9.3.0";
   previous_compiler : constant String := "9.2.0";
   binutils_version  : constant String := "2.34";
   previous_binutils : constant String := "2.33.1";
   arc_ext           : constant String := ".tzst";
   jobs_per_cpu      : constant := 2;
   task_stack_limit  : constant := 10_000_000;

   type supported_opsys is (dragonfly, freebsd, netbsd, openbsd, sunos, linux, macos);
   type supported_arch  is (x86_64, i386, aarch64);

   type cpu_range is range 1 .. 64;
   type scanners  is range cpu_range'First .. cpu_range'Last;
   type builders  is range cpu_range'First .. cpu_range'Last * jobs_per_cpu;
   type count_type is (total, success, failure, ignored, skipped);

   --  Modify following with post-patch sed accordingly
   platform_type  : constant supported_opsys := dragonfly;
   host_localbase : constant String := "/raven";
   raven_var      : constant String := "/var/ravenports";
   host_pkg8      : constant String := host_localbase & "/sbin/ravensw";
   ravenexec      : constant String := host_localbase & "/libexec/ravenexec";

end Definitions;

Bump to next version (1.54)

Bump to next version (1.54)


--  This file is covered by the Internet Software Consortium (ISC) License
--  Reference: ../License.txt

package Definitions is

   pragma Pure;

   synth_version_major : constant String := "1";
   synth_version_minor : constant String := "02";
   copyright_years     : constant String := "2015-2016";
   host_localbase      : constant String := "/usr/local";
   host_pkg8           : constant String := host_localbase & "/sbin/pkg";
   jobs_per_cpu        : constant := 2;

   type cpu_range is range 1 .. 32;
   type scanners  is range cpu_range'First .. cpu_range'Last;
   type builders  is range cpu_range'First .. cpu_range'Last * jobs_per_cpu;

end Definitions;

--  This file is covered by the Internet Software Consortium (ISC) License
--  Reference: ../License.txt

package Definitions is

   pragma Pure;

   synth_version_major : constant String := "1";
   synth_version_minor : constant String := "03";
   copyright_years     : constant String := "2015-2016";
   host_localbase      : constant String := "/usr/local";
   host_pkg8           : constant String := host_localbase & "/sbin/pkg";
   jobs_per_cpu        : constant := 2;

   type cpu_range is range 1 .. 32;
   type scanners  is range cpu_range'First .. cpu_range'Last;
   type builders  is range cpu_range'First .. cpu_range'Last * jobs_per_cpu;

end Definitions;

Bump to version 1.03 (term/dtrace fixes self-confirmed)


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

with MAT.Types;
with MAT.Events.Targets;
package MAT.Formats is

   --  Format the address into a string.
   function Addr (Value : in MAT.Types.Target_Addr) return String;

   --  Format the size into a string.
   function Size (Value : in MAT.Types.Target_Size) return String;

   --  Format the time relative to the start time.
   function Time (Value : in MAT.Types.Target_Tick_Ref;
                  Start : in MAT.Types.Target_Tick_Ref) return String;

   --  Format the duration in seconds, milliseconds or microseconds.
   function Duration (Value : in MAT.Types.Target_Tick_Ref) return String;

   --  Format a file, line, function information into a string.
   function Location (File : in Ada.Strings.Unbounded.Unbounded_String;
                      Line : in Natural;
                      Func : in Ada.Strings.Unbounded.Unbounded_String) return String;

   --  Format a short description of the event.
   function Event (Item       : in MAT.Events.Targets.Probe_Event_Type;
                   Related    : in MAT.Events.Targets.Target_Event_Vector;
                   Start_Time : in MAT.Types.Target_Tick_Ref) return String;

end MAT.Formats;

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

with MAT.Types;
with MAT.Events.Targets;
package MAT.Formats is

   --  Format the address into a string.
   function Addr (Value : in MAT.Types.Target_Addr) return String;

   --  Format the size into a string.
   function Size (Value : in MAT.Types.Target_Size) return String;

   --  Format the time relative to the start time.
   function Time (Value : in MAT.Types.Target_Tick_Ref;
                  Start : in MAT.Types.Target_Tick_Ref) return String;

   --  Format the duration in seconds, milliseconds or microseconds.
   function Duration (Value : in MAT.Types.Target_Tick_Ref) return String;

   --  Format a file, line, function information into a string.
   function Location (File : in Ada.Strings.Unbounded.Unbounded_String;
                      Line : in Natural;
                      Func : in Ada.Strings.Unbounded.Unbounded_String) return String;

   --  Format a short description of the event.
   function Event (Item : in MAT.Events.Targets.Probe_Event_Type) return String;

   --  Format a short description of the event.
   function Event (Item       : in MAT.Events.Targets.Probe_Event_Type;
                   Related    : in MAT.Events.Targets.Target_Event_Vector;
                   Start_Time : in MAT.Types.Target_Tick_Ref) return String;

end MAT.Formats;

Define a new Event function to provide a simple form of event information


-----------------------------------------------------------------------
--  files.tests -- Unit tests for files
--  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.
-----------------------------------------------------------------------

with Util.Log;
with Util.Test_Caller;

with ASF.Tests;
with AWA.Users.Models;
with AWA.Tests.Helpers.Users;

with ASF.Requests.Mockup;
with ASF.Responses.Mockup;
with ASF.Principals;
package body AWA.Users.Tests is

   use ASF.Tests;
   use AWA.Tests;

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test AWA.Users.Tests.Create_User (/users/register.xhtml)",
                       Test_Create_User'Access);
      Caller.Add_Test (Suite, "Test AWA.Users.Services.Close_Session",
                       Test_Logout_User'Access);
      Caller.Add_Test (Suite, "Test AWA.Users.Tests.Login_User (/users/login.xhtml)",
                       Test_Login_User'Access);
      Caller.Add_Test (Suite, "Test AWA.Users.Services.Lost_Password, Reset_Password",
                       Test_Reset_Password_User'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test creation of user by simulating web requests.
   --  ------------------------------
   procedure Test_Create_User (T : in out Test) is
      use type ASF.Principals.Principal_Access;

      Request   : ASF.Requests.Mockup.Request;
      Reply     : ASF.Responses.Mockup.Response;
      Email     : constant String := "Joe-" & Util.Tests.Get_Uuid & "@gmail.com";
      Principal : AWA.Tests.Helpers.Users.Test_User;
   begin
      AWA.Tests.Helpers.Users.Initialize (Principal);

      Do_Get (Request, Reply, "/auth/register.html", "create-user-1.html");

      Request.Set_Parameter ("email", Email);
      Request.Set_Parameter ("password", "asdf");
      Request.Set_Parameter ("password2", "asdf");
      Request.Set_Parameter ("firstName", "joe");
      Request.Set_Parameter ("lastName", "dalton");
      Request.Set_Parameter ("register", "1");
      Request.Set_Parameter ("register-button", "1");
      Do_Post (Request, Reply, "/auth/register.html", "create-user-2.html");

      T.Assert (Reply.Get_Status = ASF.Responses.SC_MOVED_TEMPORARILY, "Invalid response");

      --  Check that the user is NOT logged.
      T.Assert (Request.Get_User_Principal = null, "A user principal should not be defined");

      --  Now, get the access key and simulate a click on the validation link.
      declare

         Key       : AWA.Users.Models.Access_Key_Ref;
      begin
         AWA.Tests.Helpers.Users.Find_Access_Key (Principal, Email, Key);
         T.Assert (not Key.Is_Null, "There is no access key associated with the user");
         Request.Set_Parameter ("key", Key.Get_Access_Key);
         Do_Get (Request, Reply, "/auth/validate.html", "validate-user-1.html");

         T.Assert (Reply.Get_Status = ASF.Responses.SC_MOVED_TEMPORARILY, "Invalid response");
      end;

      --  Check that the user is logged and we have a user principal now.
      T.Assert (Request.Get_User_Principal /= null, "A user principal should be defined");
   end Test_Create_User;

   procedure Test_Logout_User (T : in out Test) is
   begin
      null;
   end Test_Logout_User;

   --  ------------------------------
   --  Test user authentication by simulating a web request.
   --  ------------------------------
   procedure Test_Login_User (T : in out Test) is
      use type ASF.Principals.Principal_Access;

      Request   : ASF.Requests.Mockup.Request;
      Reply     : ASF.Responses.Mockup.Response;
      Principal : AWA.Tests.Helpers.Users.Test_User;
   begin
      AWA.Tests.Set_Application_Context;
      AWA.Tests.Get_Application.Dump_Routes (Util.Log.INFO_LEVEL);
      begin
         AWA.Tests.Helpers.Users.Create_User (Principal, "Joe@gmail.com");

         --  It sometimes happen that Joe's password is changed by another test.
         --  Recover the password and make sure it is 'admin'.
      exception
         when others =>
            T.Recover_Password ("Joe@gmail.com", "admin");
      end;

      Do_Get (Request, Reply, "/auth/login.html", "login-user-1.html");

      T.Assert (Reply.Get_Status = ASF.Responses.SC_OK, "Invalid response");

      --  Check that the user is NOT logged.
      T.Assert (Request.Get_User_Principal = null, "A user principal should not be defined");

      Request.Set_Parameter ("email", "Joe@gmail.com");
      Request.Set_Parameter ("password", "admin");
      Request.Set_Parameter ("login", "1");
      Request.Set_Parameter ("login-button", "1");
      Do_Post (Request, Reply, "/auth/login.html", "login-user-2.html");

      T.Assert (Reply.Get_Status = ASF.Responses.SC_MOVED_TEMPORARILY, "Invalid response");

      --  Check that the user is logged and we have a user principal now.
      T.Assert (Request.Get_User_Principal /= null, "A user principal should be defined");
   end Test_Login_User;

   --  ------------------------------
   --  Run the recovery password process for the given user and change the password.
   --  ------------------------------
   procedure Recover_Password (T : in out Test;
                               Email : in String;
                               Password : in String) is
      use type ASF.Principals.Principal_Access;

      Request : ASF.Requests.Mockup.Request;
      Reply   : ASF.Responses.Mockup.Response;
   begin
      Do_Get (Request, Reply, "/auth/lost-password.html", "lost-password-1.html");

      T.Assert (Reply.Get_Status = ASF.Responses.SC_OK, "Invalid response");

      Request.Set_Parameter ("email", Email);
      Request.Set_Parameter ("lost-password", "1");
      Request.Set_Parameter ("lost-password-button", "1");
      Do_Post (Request, Reply, "/auth/lost-password.html", "lost-password-2.html");

      ASF.Tests.Assert_Redirect (T, "/asfunit/auth/login.html",
                                 Reply, "Invalid redirect after lost password");

      --  Now, get the access key and simulate a click on the reset password link.
      declare
         Principal : AWA.Tests.Helpers.Users.Test_User;
         Key       : AWA.Users.Models.Access_Key_Ref;
      begin
         AWA.Tests.Set_Application_Context;
         AWA.Tests.Helpers.Users.Find_Access_Key (Principal, Email, Key);
         T.Assert (not Key.Is_Null, "There is no access key associated with the user");

         --  Simulate user clicking on the reset password link.
         --  This verifies the key, login the user and redirect him to the change-password page
         Request.Set_Parameter ("key", Key.Get_Access_Key);
         Request.Set_Parameter ("password", Password);
         Request.Set_Parameter ("reset-password", "1");
         Do_Post (Request, Reply, "/auth/change-password.html", "reset-password-2.html");

         T.Assert (Reply.Get_Status = ASF.Responses.SC_MOVED_TEMPORARILY, "Invalid response");

         --  Check that the user is logged and we have a user principal now.
         T.Assert (Request.Get_User_Principal /= null, "A user principal should be defined");
      end;
   end Recover_Password;

   --  ------------------------------
   --  Test the reset password by simulating web requests.
   --  ------------------------------
   procedure Test_Reset_Password_User (T : in out Test) is
   begin
      T.Recover_Password ("Joe@gmail.com", "asf");
      T.Recover_Password ("Joe@gmail.com", "admin");
   end Test_Reset_Password_User;

end AWA.Users.Tests;

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

with Util.Log;
with Util.Test_Caller;

with ASF.Tests;
with AWA.Users.Models;
with AWA.Tests.Helpers.Users;

with ASF.Requests.Mockup;
with ASF.Responses.Mockup;
with ASF.Principals;
package body AWA.Users.Tests is

   use ASF.Tests;
   use AWA.Tests;

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test AWA.Users.Tests.Create_User (/users/register.xhtml)",
                       Test_Create_User'Access);
      Caller.Add_Test (Suite, "Test AWA.Users.Services.Close_Session",
                       Test_Logout_User'Access);
      Caller.Add_Test (Suite, "Test AWA.Users.Tests.Login_User (/users/login.xhtml)",
                       Test_Login_User'Access);
      Caller.Add_Test (Suite, "Test AWA.Users.Services.Lost_Password, Reset_Password",
                       Test_Reset_Password_User'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test creation of user by simulating web requests.
   --  ------------------------------
   procedure Test_Create_User (T : in out Test) is
      use type ASF.Principals.Principal_Access;

      Request   : ASF.Requests.Mockup.Request;
      Reply     : ASF.Responses.Mockup.Response;
      Email     : constant String := "Joe-" & Util.Tests.Get_Uuid & "@gmail.com";
      Principal : AWA.Tests.Helpers.Users.Test_User;
   begin
      AWA.Tests.Helpers.Users.Initialize (Principal);

      Do_Get (Request, Reply, "/auth/register.html", "create-user-1.html");

      Request.Set_Parameter ("email", Email);
      Request.Set_Parameter ("password", "asdf");
      Request.Set_Parameter ("password2", "asdf");
      Request.Set_Parameter ("firstName", "joe");
      Request.Set_Parameter ("lastName", "dalton");
      Request.Set_Parameter ("register", "1");
      Request.Set_Parameter ("register-button", "1");
      Do_Post (Request, Reply, "/auth/register.html", "create-user-2.html");

      T.Assert (Reply.Get_Status = ASF.Responses.SC_MOVED_TEMPORARILY, "Invalid response");

      --  Check that the user is NOT logged.
      T.Assert (Request.Get_User_Principal = null, "A user principal should not be defined");

      --  Now, get the access key and simulate a click on the validation link.
      declare

         Key       : AWA.Users.Models.Access_Key_Ref;
      begin
         AWA.Tests.Helpers.Users.Find_Access_Key (Principal, Email, Key);
         T.Assert (not Key.Is_Null, "There is no access key associated with the user");

         Do_Get (Request, Reply, "/auth/validate.html?key=" & Key.Get_Access_Key,
                 "validate-user-1.html");

         T.Assert (Reply.Get_Status = ASF.Responses.SC_MOVED_TEMPORARILY, "Invalid response");
      end;

      --  Check that the user is logged and we have a user principal now.
      T.Assert (Request.Get_User_Principal /= null, "A user principal should be defined");
   end Test_Create_User;

   procedure Test_Logout_User (T : in out Test) is
   begin
      null;
   end Test_Logout_User;

   --  ------------------------------
   --  Test user authentication by simulating a web request.
   --  ------------------------------
   procedure Test_Login_User (T : in out Test) is
      use type ASF.Principals.Principal_Access;

      Request   : ASF.Requests.Mockup.Request;
      Reply     : ASF.Responses.Mockup.Response;
      Principal : AWA.Tests.Helpers.Users.Test_User;
   begin
      AWA.Tests.Set_Application_Context;
      AWA.Tests.Get_Application.Dump_Routes (Util.Log.INFO_LEVEL);
      begin
         AWA.Tests.Helpers.Users.Create_User (Principal, "Joe@gmail.com");

         --  It sometimes happen that Joe's password is changed by another test.
         --  Recover the password and make sure it is 'admin'.
      exception
         when others =>
            T.Recover_Password ("Joe@gmail.com", "admin");
      end;

      Do_Get (Request, Reply, "/auth/login.html", "login-user-1.html");

      T.Assert (Reply.Get_Status = ASF.Responses.SC_OK, "Invalid response");

      --  Check that the user is NOT logged.
      T.Assert (Request.Get_User_Principal = null, "A user principal should not be defined");

      Request.Set_Parameter ("email", "Joe@gmail.com");
      Request.Set_Parameter ("password", "admin");
      Request.Set_Parameter ("login", "1");
      Request.Set_Parameter ("login-button", "1");
      Do_Post (Request, Reply, "/auth/login.html", "login-user-2.html");

      T.Assert (Reply.Get_Status = ASF.Responses.SC_MOVED_TEMPORARILY, "Invalid response");

      --  Check that the user is logged and we have a user principal now.
      T.Assert (Request.Get_User_Principal /= null, "A user principal should be defined");
   end Test_Login_User;

   --  ------------------------------
   --  Run the recovery password process for the given user and change the password.
   --  ------------------------------
   procedure Recover_Password (T : in out Test;
                               Email : in String;
                               Password : in String) is
      use type ASF.Principals.Principal_Access;

      Request : ASF.Requests.Mockup.Request;
      Reply   : ASF.Responses.Mockup.Response;
   begin
      Do_Get (Request, Reply, "/auth/lost-password.html", "lost-password-1.html");

      T.Assert (Reply.Get_Status = ASF.Responses.SC_OK, "Invalid response");

      Request.Set_Parameter ("email", Email);
      Request.Set_Parameter ("lost-password", "1");
      Request.Set_Parameter ("lost-password-button", "1");
      Do_Post (Request, Reply, "/auth/lost-password.html", "lost-password-2.html");

      ASF.Tests.Assert_Redirect (T, "/asfunit/auth/login.html",
                                 Reply, "Invalid redirect after lost password");

      --  Now, get the access key and simulate a click on the reset password link.
      declare
         Principal : AWA.Tests.Helpers.Users.Test_User;
         Key       : AWA.Users.Models.Access_Key_Ref;
      begin
         AWA.Tests.Set_Application_Context;
         AWA.Tests.Helpers.Users.Find_Access_Key (Principal, Email, Key);
         T.Assert (not Key.Is_Null, "There is no access key associated with the user");

         --  Simulate user clicking on the reset password link.
         --  This verifies the key, login the user and redirect him to the change-password page
         Request.Set_Parameter ("key", Key.Get_Access_Key);
         Request.Set_Parameter ("password", Password);
         Request.Set_Parameter ("reset-password", "1");
         Do_Post (Request, Reply, "/auth/change-password.html", "reset-password-2.html");

         T.Assert (Reply.Get_Status = ASF.Responses.SC_MOVED_TEMPORARILY, "Invalid response");

         --  Check that the user is logged and we have a user principal now.
         T.Assert (Request.Get_User_Principal /= null, "A user principal should be defined");
      end;
   end Recover_Password;

   --  ------------------------------
   --  Test the reset password by simulating web requests.
   --  ------------------------------
   procedure Test_Reset_Password_User (T : in out Test) is
   begin
      T.Recover_Password ("Joe@gmail.com", "asf");
      T.Recover_Password ("Joe@gmail.com", "admin");
   end Test_Reset_Password_User;

end AWA.Users.Tests;

Update the user registration test after the change of ASF.Tests.Do_Get operation


-----------------------------------------------------------------------
--  security-filters-oauth -- OAuth Security filter
--  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 Ada.Strings.Unbounded;

with ASF.Filters;
with ASF.Requests;
with ASF.Responses;
with ASF.Servlets;
with Security.OAuth.Servers; use Security.OAuth;
with Security.Policies;
with Servlet.Security.Filters.OAuth;

--  The <b>ASF.Security.Filters.OAuth</b> package provides a servlet filter that
--  implements the RFC 6749 "Accessing Protected Resources" part: it extracts the OAuth
--  access token, verifies the grant and the permission.  The servlet filter implements
--  the RFC 6750 "OAuth 2.0 Bearer Token Usage".
--
package ASF.Security.Filters.OAuth renames Servlet.Security.Filters.OAuth;

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

--  The <b>ASF.Security.Filters.OAuth</b> package provides a servlet filter that
--  implements the RFC 6749 "Accessing Protected Resources" part: it extracts the OAuth
--  access token, verifies the grant and the permission.  The servlet filter implements
--  the RFC 6750 "OAuth 2.0 Bearer Token Usage".
--
package ASF.Security.Filters.OAuth renames Servlet.Security.Filters.OAuth;

Fix compilation warnings

Fix compilation warnings


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

--  The Util.Encodes.SHA1 package generates SHA-1 hash according to
--  RFC3174 or [FIPS-180-1].
package Util.Encoders.SHA1 is

   pragma Preelaborate;

   --  The SHA-1 binary hash (160-bit).
   subtype Hash_Array is Ada.Streams.Stream_Element_Array (0 .. 19);

   --  The SHA-1 hash as hexadecimal string.
   subtype Digest is String (1 .. 40);

   subtype Base64_Digest is String (1 .. 28);
   --  ------------------------------
   --  SHA1 Context
   --  ------------------------------
   type Context is limited private;

   --  Update the hash with the string.
   procedure Update (E : in out Context;
                     S : in String);

   --  Update the hash with the string.
   procedure Update (E : in out Context;
                     S : in Ada.Streams.Stream_Element_Array);

   --  Computes the SHA1 hash and returns the raw binary hash in Hash.
   procedure Finish (E    : in out Context;
                     Hash : out Hash_Array);

   --  Computes the SHA1 hash and returns the hexadecimal hash in Hash.
   procedure Finish (E    : in out Context;
                     Hash : out Digest);

   --  Computes the SHA1 hash and returns the base64 hash in Hash.
   procedure Finish_Base64 (E    : in out Context;
                            Hash : out Base64_Digest);

   --  ------------------------------
   --  SHA1 encoder
   --  ------------------------------
   --  This Encoder translates the (binary) input stream into
   --  an SHA1 hexadecimal stream.  The encoding alphabet is: 0123456789ABCDEF.
   type Encoder is new Util.Encoders.Transformer with private;

   --  Encodes the binary input stream represented by Data into
   --  an SHA-1 hash 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);

private

   type Encoder is new Util.Encoders.Transformer with null record;

   use Interfaces;

   type H_Array is array (0 .. 4) of Unsigned_32;
   type W_Array is array (0 .. 79) of Unsigned_32;

   --  Process the message block collected in the context.
   procedure Compute (Ctx : in out Context);

   type Context is new Ada.Finalization.Limited_Controlled with record
      W           : W_Array;
      H           : H_Array;
      Pos         : Natural;
      Count       : Unsigned_64;
      Pending     : String (1 .. 3);
      Pending_Pos : Natural;
   end record;

   --  Initialize the SHA-1 context.
   overriding
   procedure Initialize (E : in out Context);

end Util.Encoders.SHA1;

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

--  The Util.Encodes.SHA1 package generates SHA-1 hash according to
--  RFC3174 or [FIPS-180-1].
package Util.Encoders.SHA1 is

   pragma Preelaborate;

   HASH_SIZE : constant := 20;

   --  The SHA-1 binary hash (160-bit).
   subtype Hash_Array is Ada.Streams.Stream_Element_Array (0 .. HASH_SIZE - 1);

   --  The SHA-1 hash as hexadecimal string.
   subtype Digest is String (1 .. 2 * HASH_SIZE);

   subtype Base64_Digest is String (1 .. 28);

   --  ------------------------------
   --  SHA1 Context
   --  ------------------------------
   type Context is limited private;

   --  Update the hash with the string.
   procedure Update (E : in out Context;
                     S : in String);

   --  Update the hash with the string.
   procedure Update (E : in out Context;
                     S : in Ada.Streams.Stream_Element_Array);

   --  Computes the SHA1 hash and returns the raw binary hash in Hash.
   procedure Finish (E    : in out Context;
                     Hash : out Hash_Array);

   --  Computes the SHA1 hash and returns the hexadecimal hash in Hash.
   procedure Finish (E    : in out Context;
                     Hash : out Digest);

   --  Computes the SHA1 hash and returns the base64 hash in Hash.
   procedure Finish_Base64 (E    : in out Context;
                            Hash : out Base64_Digest);

   --  ------------------------------
   --  SHA1 encoder
   --  ------------------------------
   --  This Encoder translates the (binary) input stream into
   --  an SHA1 hexadecimal stream.  The encoding alphabet is: 0123456789ABCDEF.
   type Encoder is new Util.Encoders.Transformer with private;

   --  Encodes the binary input stream represented by Data into
   --  an SHA-1 hash 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);

private

   type Encoder is new Util.Encoders.Transformer with null record;

   use Interfaces;

   type H_Array is array (0 .. 4) of Unsigned_32;
   type W_Array is array (0 .. 79) of Unsigned_32;

   --  Process the message block collected in the context.
   procedure Compute (Ctx : in out Context);

   type Context is new Ada.Finalization.Limited_Controlled with record
      W           : W_Array;
      H           : H_Array;
      Pos         : Natural;
      Count       : Unsigned_64;
      Pending     : String (1 .. 3);
      Pending_Pos : Natural;
   end record;

   --  Initialize the SHA-1 context.
   overriding
   procedure Initialize (E : in out Context);

end Util.Encoders.SHA1;

Define HASH_SIZE and use it

Define HASH_SIZE and use it


-----------------------------------------------------------------------
--  util-streams-tests -- Unit tests for encoding buffered streams
--  Copyright (C) 2017, 2018, 2019 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Util.Test_Caller;
with Util.Encoders.AES;
with Util.Streams.Files;
with Util.Streams.Texts;
with Util.Streams.Base64;
with Util.Streams.AES;
with Ada.IO_Exceptions;
with Ada.Streams.Stream_IO;
package body Util.Streams.Tests is

   use Util.Streams.Files;
   use Ada.Streams.Stream_IO;

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

   generic
      Mode  : in Util.Encoders.AES.AES_Mode;
      Label : in String;
   procedure Test_AES_Mode (T : in out Test);

   procedure Test_AES (T     : in out Test;
                       Item  : in String;
                       Count : in Positive;
                       Mode  : in Util.Encoders.AES.AES_Mode;
                       Label : in String) is
      Reader   : aliased Util.Streams.Texts.Reader_Stream;
      Decipher : aliased Util.Streams.AES.Decoding_Stream;
      Cipher   : aliased Util.Streams.AES.Encoding_Stream;
      Print    : Util.Streams.Texts.Print_Stream;
      Key      : Util.Encoders.Secret_Key
        := Util.Encoders.Create ("0123456789abcdef0123456789abcdef");
   begin
      --  Print -> Cipher -> Decipher
      Decipher.Initialize (64 * 1024);
      Decipher.Set_Key (Key, Mode);
      Cipher.Initialize (Decipher'Access, 1024);
      Cipher.Set_Key (Key, Mode);
      Print.Initialize (Cipher'Access);
      for I in 1 .. Count loop
         Print.Write (Item);
      end loop;
      Print.Flush;
      Util.Tests.Assert_Equals (T,
                                Item'Length * Count,
                                Decipher.Get_Size,
                                Label & ": decipher buffer has the wrong size mode");

      --  Read content in Decipher
      Reader.Initialize (Decipher);
      for I in 1 .. Count loop
         declare
            L : String (Item'Range) := (others => ' ');
         begin
            for J in L'Range loop
               Reader.Read (L (J));
            end loop;
            Util.Tests.Assert_Equals (T, Item, L, Label & ": wrong value");

         exception
            when Ada.IO_Exceptions.Data_Error =>
               Util.Tests.Assert_Equals (T, Item, L, Label & ": wrong value (DATA error)");
         end;
      end loop;
   end Test_AES;

   procedure Test_AES_Mode (T : in out Test) is
   begin
      for I in 1 .. 128 loop
         Test_AES (T, "a", I, Mode, Label);
      end loop;
      for I in 1 .. 128 loop
         Test_AES (T, "ab", I, Mode, Label);
      end loop;
      for I in 1 .. 128 loop
         Test_AES (T, "abc", I, Mode, Label);
      end loop;
   end Test_AES_Mode;

   procedure Test_AES_ECB is
      new Test_AES_Mode (Mode => Util.Encoders.AES.ECB, Label => "AES-ECB");

   procedure Test_AES_CBC is
      new Test_AES_Mode (Mode => Util.Encoders.AES.CBC, Label => "AES-CBC");

   procedure Test_AES_PCBC is
      new Test_AES_Mode (Mode => Util.Encoders.AES.PCBC, Label => "AES-PCBC");

   procedure Test_AES_CFB is
      new Test_AES_Mode (Mode => Util.Encoders.AES.PCBC, Label => "AES-CFB");

   procedure Test_AES_OFB is
      new Test_AES_Mode (Mode => Util.Encoders.AES.PCBC, Label => "AES-OFB");

   procedure Test_AES_CTR is
      new Test_AES_Mode (Mode => Util.Encoders.AES.PCBC, Label => "AES-CTR");

   procedure Test_Base64_Stream (T : in out Test) is
      Stream  : aliased File_Stream;
      Buffer  : aliased Util.Streams.Base64.Encoding_Stream;
      Print   : Util.Streams.Texts.Print_Stream;
      Path    : constant String := Util.Tests.Get_Test_Path ("regtests/result/test-stream.b64");
      Expect  : constant String := Util.Tests.Get_Path ("regtests/expect/test-stream.b64");
   begin
      Print.Initialize (Output => Buffer'Access, Size => 5);
      Buffer.Initialize (Output => Stream'Access,
                         Size   => 1024);
      Stream.Create (Mode => Out_File, Name => Path);
      for I in 1 .. 32 loop
         Print.Write ("abcd");
         Print.Write (" fghij");
         Print.Write (ASCII.LF);
      end loop;
      Print.Flush;
      Stream.Close;

      Util.Tests.Assert_Equal_Files (T       => T,
                                     Expect  => Expect,
                                     Test    => Path,
                                     Message => "Base64 stream");
   end Test_Base64_Stream;

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Util.Streams.Base64.Write, Read",
                       Test_Base64_Stream'Access);
      Caller.Add_Test (Suite, "Test Util.Streams.AES (AES-ECB)",
                       Test_AES_ECB'Access);
      Caller.Add_Test (Suite, "Test Util.Streams.AES (AES-CBC)",
                       Test_AES_CBC'Access);
      Caller.Add_Test (Suite, "Test Util.Streams.AES (AES-PCBC)",
                       Test_AES_PCBC'Access);
      Caller.Add_Test (Suite, "Test Util.Streams.AES (AES-CFB)",
                       Test_AES_CFB'Access);
      Caller.Add_Test (Suite, "Test Util.Streams.AES (AES-OFB)",
                       Test_AES_OFB'Access);
      Caller.Add_Test (Suite, "Test Util.Streams.AES (AES-CTR)",
                       Test_AES_CTR'Access);
   end Add_Tests;

end Util.Streams.Tests;

-----------------------------------------------------------------------
--  util-streams-tests -- Unit tests for encoding buffered streams
--  Copyright (C) 2017, 2018, 2019 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Util.Test_Caller;
with Util.Streams.Files;
with Util.Streams.Texts;
with Util.Streams.Base64;
with Util.Streams.AES;
with Ada.IO_Exceptions;
with Ada.Streams.Stream_IO;
package body Util.Streams.Tests is

   use Util.Streams.Files;
   use Ada.Streams.Stream_IO;

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

   generic
      Mode  : in Util.Encoders.AES.AES_Mode;
      Label : in String;
   procedure Test_AES_Mode (T : in out Test);

   procedure Test_AES (T     : in out Test;
                       Item  : in String;
                       Count : in Positive;
                       Mode  : in Util.Encoders.AES.AES_Mode;
                       Label : in String) is
      Reader   : aliased Util.Streams.Texts.Reader_Stream;
      Decipher : aliased Util.Streams.AES.Decoding_Stream;
      Cipher   : aliased Util.Streams.AES.Encoding_Stream;
      Print    : Util.Streams.Texts.Print_Stream;
      Key      : Util.Encoders.Secret_Key
        := Util.Encoders.Create ("0123456789abcdef0123456789abcdef");
   begin
      --  Print -> Cipher -> Decipher
      Decipher.Initialize (64 * 1024);
      Decipher.Set_Key (Key, Mode);
      Cipher.Initialize (Decipher'Access, 1024);
      Cipher.Set_Key (Key, Mode);
      Print.Initialize (Cipher'Access);
      for I in 1 .. Count loop
         Print.Write (Item);
      end loop;
      Print.Flush;
      Util.Tests.Assert_Equals (T,
                                Item'Length * Count,
                                Decipher.Get_Size,
                                Label & ": decipher buffer has the wrong size mode");

      --  Read content in Decipher
      Reader.Initialize (Decipher);
      for I in 1 .. Count loop
         declare
            L : String (Item'Range) := (others => ' ');
         begin
            for J in L'Range loop
               Reader.Read (L (J));
            end loop;
            Util.Tests.Assert_Equals (T, Item, L, Label & ": wrong value");

         exception
            when Ada.IO_Exceptions.Data_Error =>
               Util.Tests.Assert_Equals (T, Item, L, Label & ": wrong value (DATA error)");
         end;
      end loop;
   end Test_AES;

   procedure Test_AES_Mode (T : in out Test) is
   begin
      for I in 1 .. 128 loop
         Test_AES (T, "a", I, Mode, Label);
      end loop;
      for I in 1 .. 128 loop
         Test_AES (T, "ab", I, Mode, Label);
      end loop;
      for I in 1 .. 128 loop
         Test_AES (T, "abc", I, Mode, Label);
      end loop;
   end Test_AES_Mode;

   procedure Test_AES_ECB is
      new Test_AES_Mode (Mode => Util.Encoders.AES.ECB, Label => "AES-ECB");

   procedure Test_AES_CBC is
      new Test_AES_Mode (Mode => Util.Encoders.AES.CBC, Label => "AES-CBC");

   procedure Test_AES_PCBC is
      new Test_AES_Mode (Mode => Util.Encoders.AES.PCBC, Label => "AES-PCBC");

   procedure Test_AES_CFB is
      new Test_AES_Mode (Mode => Util.Encoders.AES.PCBC, Label => "AES-CFB");

   procedure Test_AES_OFB is
      new Test_AES_Mode (Mode => Util.Encoders.AES.PCBC, Label => "AES-OFB");

   procedure Test_AES_CTR is
      new Test_AES_Mode (Mode => Util.Encoders.AES.PCBC, Label => "AES-CTR");

   procedure Test_Base64_Stream (T : in out Test) is
      Stream  : aliased File_Stream;
      Buffer  : aliased Util.Streams.Base64.Encoding_Stream;
      Print   : Util.Streams.Texts.Print_Stream;
      Path    : constant String := Util.Tests.Get_Test_Path ("regtests/result/test-stream.b64");
      Expect  : constant String := Util.Tests.Get_Path ("regtests/expect/test-stream.b64");
   begin
      Print.Initialize (Output => Buffer'Access, Size => 5);
      Buffer.Initialize (Output => Stream'Access,
                         Size   => 1024);
      Stream.Create (Mode => Out_File, Name => Path);
      for I in 1 .. 32 loop
         Print.Write ("abcd");
         Print.Write (" fghij");
         Print.Write (ASCII.LF);
      end loop;
      Print.Flush;
      Stream.Close;

      Util.Tests.Assert_Equal_Files (T       => T,
                                     Expect  => Expect,
                                     Test    => Path,
                                     Message => "Base64 stream");
   end Test_Base64_Stream;

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Util.Streams.Base64.Write, Read",
                       Test_Base64_Stream'Access);
      Caller.Add_Test (Suite, "Test Util.Streams.AES (AES-ECB)",
                       Test_AES_ECB'Access);
      Caller.Add_Test (Suite, "Test Util.Streams.AES (AES-CBC)",
                       Test_AES_CBC'Access);
      Caller.Add_Test (Suite, "Test Util.Streams.AES (AES-PCBC)",
                       Test_AES_PCBC'Access);
      Caller.Add_Test (Suite, "Test Util.Streams.AES (AES-CFB)",
                       Test_AES_CFB'Access);
      Caller.Add_Test (Suite, "Test Util.Streams.AES (AES-OFB)",
                       Test_AES_OFB'Access);
      Caller.Add_Test (Suite, "Test Util.Streams.AES (AES-CTR)",
                       Test_AES_CTR'Access);
   end Add_Tests;

end Util.Streams.Tests;

Remove unused with clause

Remove unused with clause


--  This file is covered by the Internet Software Consortium (ISC) License
--  Reference: ../License.txt

package Definitions is

   pragma Pure;

   raven_version_major : constant String := "0";
   raven_version_minor : constant String := "74";
   copyright_years     : constant String := "2015-2017";

   raven_tool        : constant String := "ravenadm";
   variant_standard  : constant String := "standard";
   contact_nobody    : constant String := "nobody";
   contact_automaton : constant String := "automaton";
   dlgroup_main      : constant String := "main";
   dlgroup_none      : constant String := "none";
   options_none      : constant String := "none";
   options_all       : constant String := "all";
   broken_all        : constant String := "all";
   boolean_yes       : constant String := "yes";
   homepage_none     : constant String := "none";
   spkg_complete     : constant String := "complete";
   spkg_docs         : constant String := "docs";
   spkg_examples     : constant String := "examples";
   ports_default     : constant String := "floating";
   default_ssl       : constant String := "libressl";
   default_mysql     : constant String := "oracle-5.7";
   default_lua       : constant String := "5.3";
   default_perl      : constant String := "5.26";
   default_pgsql     : constant String := "9.6";
   default_php       : constant String := "7.1";
   default_python3   : constant String := "3.6";
   default_ruby      : constant String := "2.4";
   default_tcltk     : constant String := "8.6";
   default_firebird  : constant String := "2.5";
   default_compiler  : constant String := "gcc7";
   compiler_version  : constant String := "7.2.0";
   previous_compiler : constant String := "7.1.0";
   binutils_version  : constant String := "2.29";
   previous_binutils : constant String := "2.28";
   arc_ext           : constant String := ".txz";
   jobs_per_cpu      : constant := 2;

   type supported_opsys is (dragonfly, freebsd, netbsd, openbsd, sunos, linux, macos);
   type supported_arch  is (x86_64, i386, aarch64);

   type cpu_range is range 1 .. 32;
   type scanners  is range cpu_range'First .. cpu_range'Last;
   type builders  is range cpu_range'First .. cpu_range'Last * jobs_per_cpu;
   type count_type is (total, success, failure, ignored, skipped);

   --  Modify following with post-patch sed accordingly
   platform_type  : constant supported_opsys := dragonfly;
   host_localbase : constant String := "/raven";
   host_pkg8      : constant String := host_localbase & "/sbin/pkg-static";
   ravenexec      : constant String := host_localbase & "/libexec/ravenexec";

end Definitions;

--  This file is covered by the Internet Software Consortium (ISC) License
--  Reference: ../License.txt

package Definitions is

   pragma Pure;

   raven_version_major : constant String := "0";
   raven_version_minor : constant String := "75";
   copyright_years     : constant String := "2015-2017";

   raven_tool        : constant String := "ravenadm";
   variant_standard  : constant String := "standard";
   contact_nobody    : constant String := "nobody";
   contact_automaton : constant String := "automaton";
   dlgroup_main      : constant String := "main";
   dlgroup_none      : constant String := "none";
   options_none      : constant String := "none";
   options_all       : constant String := "all";
   broken_all        : constant String := "all";
   boolean_yes       : constant String := "yes";
   homepage_none     : constant String := "none";
   spkg_complete     : constant String := "complete";
   spkg_docs         : constant String := "docs";
   spkg_examples     : constant String := "examples";
   ports_default     : constant String := "floating";
   default_ssl       : constant String := "libressl";
   default_mysql     : constant String := "oracle-5.7";
   default_lua       : constant String := "5.3";
   default_perl      : constant String := "5.26";
   default_pgsql     : constant String := "9.6";
   default_php       : constant String := "7.1";
   default_python3   : constant String := "3.6";
   default_ruby      : constant String := "2.4";
   default_tcltk     : constant String := "8.6";
   default_firebird  : constant String := "2.5";
   default_compiler  : constant String := "gcc7";
   compiler_version  : constant String := "7.2.0";
   previous_compiler : constant String := "7.1.0";
   binutils_version  : constant String := "2.29.1";
   previous_binutils : constant String := "2.29";
   arc_ext           : constant String := ".txz";
   jobs_per_cpu      : constant := 2;

   type supported_opsys is (dragonfly, freebsd, netbsd, openbsd, sunos, linux, macos);
   type supported_arch  is (x86_64, i386, aarch64);

   type cpu_range is range 1 .. 32;
   type scanners  is range cpu_range'First .. cpu_range'Last;
   type builders  is range cpu_range'First .. cpu_range'Last * jobs_per_cpu;
   type count_type is (total, success, failure, ignored, skipped);

   --  Modify following with post-patch sed accordingly
   platform_type  : constant supported_opsys := dragonfly;
   host_localbase : constant String := "/raven";
   host_pkg8      : constant String := host_localbase & "/sbin/pkg-static";
   ravenexec      : constant String := host_localbase & "/libexec/ravenexec";

end Definitions;

Update ravenadm to use binutils 2.29.1 instead of 2.29


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

   type Event is tagged private;

   --  Get the time identifying when the event was created.
   function Get_Time (Ev : Event) return Ada.Calendar.Time;

private

   type Event is tagged record
      Date : Ada.Calendar.Time := Ada.Calendar.Clock;
   end record;

end Util.Events;

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

   type Event is tagged private;

   --  Get the time identifying when the event was created.
   function Get_Time (Ev : Event) return Ada.Calendar.Time;

   type Event_Listener is limited interface;

private

   type Event is tagged record
      Date : Ada.Calendar.Time := Ada.Calendar.Clock;
   end record;

end Util.Events;

Declare the Event_Listener interface

Declare the Event_Listener interface


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

with Ada.Finalization;
with Ada.Strings.Unbounded;
package Util.Processes is

   Invalid_State : exception;

   Process_Error : exception;

   --  The optional process pipes:
   --

   --
NONE

   --
the process will inherit the standard input, output and error.

   --
READ

   --
a pipe is created to read the process standard output.

   --
READ_ERROR

   --
a pipe is created to read the process standard error.  The output and input are
   --    inherited.

   --
READ_ALL

   --
similar to READ the same pipe is used for the process standard error.

   --
WRITE

   --
a pipe is created to write on the process standard input.

   --
READ_WRITE

   --
Combines the READ and WRITE modes.

   --
READ_WRITE_ALL

   --
Combines the READ_ALL and WRITE modes.

   --

   type Pipe_Mode is (NONE, READ, READ_ERROR, READ_ALL, WRITE, READ_WRITE, READ_WRITE_ALL);

   subtype String_Access is Ada.Strings.Unbounded.String_Access;

   type Argument_List is array (Positive range <>) of String_Access;

   type Process_Identifier is new Integer;

   --  ------------------------------
   --  Process
   --  ------------------------------
   type Process is limited private;

   --  Before launching the process, redirect the input stream of the process
   --  to the specified file.
   --  Raises Invalid_State if the process is running.
   procedure Set_Input_Stream (Proc : in out Process;
                               File : in String);

   --  Set the output stream of the process.
   --  Raises Invalid_State if the process is running.
   procedure Set_Output_Stream (Proc   : in out Process;
                                File   : in String;
                                Append : in Boolean := False);

   --  Set the error stream of the process.
   --  Raises Invalid_State if the process is running.
   procedure Set_Error_Stream (Proc   : in out Process;
                               File   : in String;
                               Append : in Boolean := False);

   --  Set the working directory that the process will use once it is created.
   --  The directory must exist or the Invalid_Directory exception will be raised.
   procedure Set_Working_Directory (Proc : in out Process;
                                    Path : in String);

   --  Set the shell executable path to use to launch a command.  The default on Unix is
   --  the /bin/sh command.  Argument splitting is done by the /bin/sh -c command.
   --  When setting an empty shell command, the argument splitting is done by the
   --  <tt>Spawn</tt> procedure.
   procedure Set_Shell (Proc  : in out Process;
                        Shell : in String);

   --  Append the argument to the current process argument list.
   --  Raises Invalid_State if the process is running.
   procedure Append_Argument (Proc : in out Process;
                              Arg  : in String);

   --  Spawn a new process with the given command and its arguments.  The standard input, output
   --  and error streams are either redirected to a file or to a stream object.
   procedure Spawn (Proc      : in out Process;
                    Command   : in String;
                    Arguments : in Argument_List);

   procedure Spawn (Proc      : in out Process;
                    Command   : in String;
                    Mode      : in Pipe_Mode := NONE);

   --  Wait for the process to terminate.
   procedure Wait (Proc : in out Process);

   --  Terminate the process by sending a signal on Unix and exiting the process on Windows.
   --  This operation is not portable and has a different behavior between Unix and Windows.
   --  Its intent is to stop the process.
   procedure Stop (Proc   : in out Process;
                   Signal : in Positive := 15);

   --  Get the process exit status.
   function Get_Exit_Status (Proc : in Process) return Integer;

   --  Get the process identifier.
   function Get_Pid (Proc : in Process) return Process_Identifier;

   --  Returns True if the process is running.
   function Is_Running (Proc : in Process) return Boolean;

   --  Get the process input stream allowing to write on the process standard input.
   function Get_Input_Stream (Proc : in Process) return Util.Streams.Output_Stream_Access;

   --  Get the process output stream allowing to read the process standard output.
   function Get_Output_Stream (Proc : in Process) return Util.Streams.Input_Stream_Access;

   --  Get the process error stream allowing to read the process standard output.
   function Get_Error_Stream (Proc : in Process) return Util.Streams.Input_Stream_Access;

private

   --  The System_Process interface is specific to the system.  On Unix, it holds the
   --  process identifier.  On Windows, more information is necessary, including the process
   --  and thread handles.  It's a little bit overkill to setup an interface for this but
   --  it looks cleaner than having specific system fields here.
   type System_Process is limited interface;
   type System_Process_Access is access all System_Process'Class;

   type Process is new Ada.Finalization.Limited_Controlled with record
      Pid        : Process_Identifier := -1;
      Sys        : System_Process_Access := null;
      Exit_Value : Integer := -1;
      Dir        : Ada.Strings.Unbounded.Unbounded_String;
      In_File    : Ada.Strings.Unbounded.Unbounded_String;
      Out_File   : Ada.Strings.Unbounded.Unbounded_String;
      Err_File   : Ada.Strings.Unbounded.Unbounded_String;
      Shell      : Ada.Strings.Unbounded.Unbounded_String;
      Out_Append : Boolean := False;
      Err_Append : Boolean := False;
      Output     : Util.Streams.Input_Stream_Access := null;
      Input      : Util.Streams.Output_Stream_Access := null;
      Error      : Util.Streams.Input_Stream_Access := null;
   end record;

   --  Initialize the process instance.
   overriding
   procedure Initialize (Proc : in out Process);

   --  Deletes the process instance.
   overriding
   procedure Finalize (Proc : in out Process);

   --  Wait for the process to exit.
   procedure Wait (Sys     : in out System_Process;
                   Proc    : in out Process'Class;
                   Timeout : in Duration) is abstract;

   --  Terminate the process by sending a signal on Unix and exiting the process on Windows.
   --  This operation is not portable and has a different behavior between Unix and Windows.
   --  Its intent is to stop the process.
   procedure Stop (Sys    : in out System_Process;
                   Proc   : in out Process'Class;
                   Signal : in Positive := 15) is abstract;

   --  Spawn a new process.
   procedure Spawn (Sys  : in out System_Process;
                    Proc : in out Process'Class;
                    Mode : in Pipe_Mode := NONE) is abstract;

   --  Append the argument to the process argument list.
   procedure Append_Argument (Sys : in out System_Process;
                              Arg : in String) is abstract;

   --  Set the process input, output and error streams to redirect and use specified files.
   procedure Set_Streams (Sys           : in out System_Process;
                          Input         : in String;
                          Output        : in String;
                          Error         : in String;
                          Append_Output : in Boolean;
                          Append_Error  : in Boolean) is abstract;

   --  Deletes the storage held by the system process.
   procedure Finalize (Sys : in out System_Process) is abstract;

end Util.Processes;

-----------------------------------------------------------------------
--  util-processes -- Process creation and control
--  Copyright (C) 2011, 2012, 2016, 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.Streams;
with Util.Systems.Types;

with Ada.Finalization;
with Ada.Strings.Unbounded;
package Util.Processes is

   Invalid_State : exception;

   Process_Error : exception;

   --  The optional process pipes:
   --

   --
NONE

   --
the process will inherit the standard input, output and error.

   --
READ

   --
a pipe is created to read the process standard output.

   --
READ_ERROR

   --
a pipe is created to read the process standard error.  The output and input are
   --    inherited.

   --
READ_ALL

   --
similar to READ the same pipe is used for the process standard error.

   --
WRITE

   --
a pipe is created to write on the process standard input.

   --
READ_WRITE

   --
Combines the READ and WRITE modes.

   --
READ_WRITE_ALL

   --
Combines the READ_ALL and WRITE modes.

   --

   type Pipe_Mode is (NONE, READ, READ_ERROR, READ_ALL, WRITE, READ_WRITE, READ_WRITE_ALL);

   subtype String_Access is Ada.Strings.Unbounded.String_Access;

   subtype File_Type is Util.Systems.Types.File_Type;

   type Argument_List is array (Positive range <>) of String_Access;

   type Process_Identifier is new Integer;

   --  ------------------------------
   --  Process
   --  ------------------------------
   type Process is limited private;

   --  Before launching the process, redirect the input stream of the process
   --  to the specified file.
   --  Raises Invalid_State if the process is running.
   procedure Set_Input_Stream (Proc : in out Process;
                               File : in String);

   --  Set the output stream of the process.
   --  Raises Invalid_State if the process is running.
   procedure Set_Output_Stream (Proc   : in out Process;
                                File   : in String;
                                Append : in Boolean := False);

   --  Set the error stream of the process.
   --  Raises Invalid_State if the process is running.
   procedure Set_Error_Stream (Proc   : in out Process;
                               File   : in String;
                               Append : in Boolean := False);

   --  Set the working directory that the process will use once it is created.
   --  The directory must exist or the Invalid_Directory exception will be raised.
   procedure Set_Working_Directory (Proc : in out Process;
                                    Path : in String);

   --  Set the shell executable path to use to launch a command.  The default on Unix is
   --  the /bin/sh command.  Argument splitting is done by the /bin/sh -c command.
   --  When setting an empty shell command, the argument splitting is done by the
   --  <tt>Spawn</tt> procedure.
   procedure Set_Shell (Proc  : in out Process;
                        Shell : in String);

   --  Closes the given file descriptor in the child process before executing the command.
   procedure Add_Close (Proc  : in out Process;
                        Fd    : in File_Type);

   --  Append the argument to the current process argument list.
   --  Raises Invalid_State if the process is running.
   procedure Append_Argument (Proc : in out Process;
                              Arg  : in String);

   --  Spawn a new process with the given command and its arguments.  The standard input, output
   --  and error streams are either redirected to a file or to a stream object.
   procedure Spawn (Proc      : in out Process;
                    Command   : in String;
                    Arguments : in Argument_List);

   procedure Spawn (Proc      : in out Process;
                    Command   : in String;
                    Mode      : in Pipe_Mode := NONE);

   --  Wait for the process to terminate.
   procedure Wait (Proc : in out Process);

   --  Terminate the process by sending a signal on Unix and exiting the process on Windows.
   --  This operation is not portable and has a different behavior between Unix and Windows.
   --  Its intent is to stop the process.
   procedure Stop (Proc   : in out Process;
                   Signal : in Positive := 15);

   --  Get the process exit status.
   function Get_Exit_Status (Proc : in Process) return Integer;

   --  Get the process identifier.
   function Get_Pid (Proc : in Process) return Process_Identifier;

   --  Returns True if the process is running.
   function Is_Running (Proc : in Process) return Boolean;

   --  Get the process input stream allowing to write on the process standard input.
   function Get_Input_Stream (Proc : in Process) return Util.Streams.Output_Stream_Access;

   --  Get the process output stream allowing to read the process standard output.
   function Get_Output_Stream (Proc : in Process) return Util.Streams.Input_Stream_Access;

   --  Get the process error stream allowing to read the process standard output.
   function Get_Error_Stream (Proc : in Process) return Util.Streams.Input_Stream_Access;

private

   type File_Type_Array is array (Positive range <>) of File_Type;
   type File_Type_Array_Access is access all File_Type_Array;

   --  The System_Process interface is specific to the system.  On Unix, it holds the
   --  process identifier.  On Windows, more information is necessary, including the process
   --  and thread handles.  It's a little bit overkill to setup an interface for this but
   --  it looks cleaner than having specific system fields here.
   type System_Process is limited interface;
   type System_Process_Access is access all System_Process'Class;

   type Process is new Ada.Finalization.Limited_Controlled with record
      Pid        : Process_Identifier := -1;
      Sys        : System_Process_Access := null;
      Exit_Value : Integer := -1;
      Dir        : Ada.Strings.Unbounded.Unbounded_String;
      In_File    : Ada.Strings.Unbounded.Unbounded_String;
      Out_File   : Ada.Strings.Unbounded.Unbounded_String;
      Err_File   : Ada.Strings.Unbounded.Unbounded_String;
      Shell      : Ada.Strings.Unbounded.Unbounded_String;
      Out_Append : Boolean := False;
      Err_Append : Boolean := False;
      Output     : Util.Streams.Input_Stream_Access := null;
      Input      : Util.Streams.Output_Stream_Access := null;
      Error      : Util.Streams.Input_Stream_Access := null;
      To_Close   : File_Type_Array_Access;
   end record;

   --  Initialize the process instance.
   overriding
   procedure Initialize (Proc : in out Process);

   --  Deletes the process instance.
   overriding
   procedure Finalize (Proc : in out Process);

   --  Wait for the process to exit.
   procedure Wait (Sys     : in out System_Process;
                   Proc    : in out Process'Class;
                   Timeout : in Duration) is abstract;

   --  Terminate the process by sending a signal on Unix and exiting the process on Windows.
   --  This operation is not portable and has a different behavior between Unix and Windows.
   --  Its intent is to stop the process.
   procedure Stop (Sys    : in out System_Process;
                   Proc   : in out Process'Class;
                   Signal : in Positive := 15) is abstract;

   --  Spawn a new process.
   procedure Spawn (Sys  : in out System_Process;
                    Proc : in out Process'Class;
                    Mode : in Pipe_Mode := NONE) is abstract;

   --  Append the argument to the process argument list.
   procedure Append_Argument (Sys : in out System_Process;
                              Arg : in String) is abstract;

   --  Set the process input, output and error streams to redirect and use specified files.
   procedure Set_Streams (Sys           : in out System_Process;
                          Input         : in String;
                          Output        : in String;
                          Error         : in String;
                          Append_Output : in Boolean;
                          Append_Error  : in Boolean;
                          To_Close      : in File_Type_Array_Access) is abstract;

   --  Deletes the storage held by the system process.
   procedure Finalize (Sys : in out System_Process) is abstract;

end Util.Processes;

Declare File_Type type and add Add_Close procedure Add To_Close parameter to the Set_Streams procedure