--  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 Ada.Characters.Latin_1;
with Ada.Strings.Fixed;
with Ada.Text_IO;

with Orka.OS;
with Orka.Strings;

package body Orka.Terminals is

   Style_Codes : constant array (Style) of Natural :=
     (Default   => 0,
      Bold      => 1,
      Dark      => 2,
      Italic    => 3,
      Underline => 4,
      Blink     => 5,
      Reversed  => 7,
      Cross_Out => 9);

   Foreground_Color_Codes : constant array (Color) of Natural :=
     (Default => 0,
      Grey    => 30,
      Red     => 31,
      Green   => 32,
      Yellow  => 33,
      Blue    => 34,
      Magenta => 35,
      Cyan    => 36,
      White   => 37);

   Background_Color_Codes : constant array (Color) of Natural :=
     (Default => 0,
      Grey    => 40,
      Red     => 41,
      Green   => 42,
      Yellow  => 43,
      Blue    => 44,
      Magenta => 45,
      Cyan    => 46,
      White   => 47);

   package L renames Ada.Characters.Latin_1;
   package SF renames Ada.Strings.Fixed;

   Reset : constant String := L.ESC & "[0m";

   function Sequence (Code : Natural) return String is
      Image : constant String := SF.Trim (Code'Image, Ada.Strings.Both);
   begin
      return (if Code /= 0 then L.ESC & "[" & Image & "m" else "");
   end Sequence;

   function Colorize (Text : String; Foreground, Background : Color := Default;
                      Attribute : Style := Default) return String is
      FG : constant String := Sequence (Foreground_Color_Codes (Foreground));
      BG : constant String := Sequence (Background_Color_Codes (Background));
      ST : constant String := Sequence (Style_Codes (Attribute));
   begin
      return Reset & FG & BG & ST & Text & Reset;
   end Colorize;

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

   Time_Zero : constant Duration := Orka.OS.Monotonic_Clock;

   Day_In_Seconds : constant := 24.0 * 60.0 * 60.0;

   function Time_Image return String is
      Seconds_Since_Zero : Duration := Orka.OS.Monotonic_Clock - Time_Zero;
      Days_Since_Zero    : Natural := 0;
   begin
      while Seconds_Since_Zero > Day_In_Seconds loop
         Seconds_Since_Zero := Seconds_Since_Zero - Day_In_Seconds;
         Days_Since_Zero    := Days_Since_Zero + 1;
      end loop;

      declare
         Seconds_Rounded : constant Natural :=
           Natural (Duration'Max (0.0, Seconds_Since_Zero - 0.5));

         Hour       : constant Natural := Seconds_Rounded / 3600;
         Minute     : constant Natural := (Seconds_Rounded mod 3600) / 60;
         Second     : constant Natural := Seconds_Rounded mod 60;

         Sub_Second : constant Duration :=
           Seconds_Since_Zero - Duration (Hour * 3600 + Minute * 60 + Second);

         --  Remove first character (space) from ' hhmmss' image and then pad it to six digits
         Image1 : constant String := Natural'Image
           ((Days_Since_Zero * 24 + Hour) * 1e4 + Minute * 1e2 + Second);
         Image2 : constant String := SF.Tail (Image1 (2 .. Image1'Last), 6, '0');

         --  Insert ':' characters to get 'hh:mm:ss'
         Image3 : constant String := SF.Insert (Image2, 5, ":");
         Image4 : constant String := SF.Insert (Image3, 3, ":");

         --  Take image without first character (space) and then pad it to six digits
         Image5 : constant String := Natural'Image (Natural (Sub_Second * 1e6));
         Image6 : constant String := SF.Tail (Image5 (2 .. Image5'Last), 6, '0');
      begin
         return Image4 & "." & Image6;
      end;
   end Time_Image;

   package Duration_IO is new Ada.Text_IO.Fixed_IO (Duration);

   type String_Access is not null access String;

   Suffices : constant array (1 .. 3) of String_Access
     := (new String'("s"),
         new String'("ms"),
         new String'("us"));
   Last_Suffix : constant String_Access := Suffices (Suffices'Last);

   function Image (Value : Duration) return String is
      Result : String   := "-9999.999";
      Number : Duration := Value;

      Suffix : String_Access := Suffices (Suffices'First);
   begin
      for S of Suffices loop
         Suffix := S;
         exit when Number >= 1.0 or else Number <= -1.0 or else S = Last_Suffix;
         Number := Number * 1e3;
      end loop;

      begin
         Duration_IO.Put (Result, Item => Number, Aft => 3);
      exception
         when others =>
            return Number'Image & " " & Suffix.all;
      end;
      return Result & " " & Suffix.all;
   end Image;

   function Trim (Value : String) return String renames Orka.Strings.Trim;

   function Strip_Line_Term (Value : String) return String renames Orka.Strings.Strip_Line_Term;

end Orka.Terminals;

--  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 Ada.Characters.Latin_1;
with Ada.Strings.Fixed;

with Orka.OS;
with Orka.Strings;

package body Orka.Terminals is

   Style_Codes : constant array (Style) of Natural :=
     (Default   => 0,
      Bold      => 1,
      Dark      => 2,
      Italic    => 3,
      Underline => 4,
      Blink     => 5,
      Reversed  => 7,
      Cross_Out => 9);

   Foreground_Color_Codes : constant array (Color) of Natural :=
     (Default => 0,
      Grey    => 30,
      Red     => 31,
      Green   => 32,
      Yellow  => 33,
      Blue    => 34,
      Magenta => 35,
      Cyan    => 36,
      White   => 37);

   Background_Color_Codes : constant array (Color) of Natural :=
     (Default => 0,
      Grey    => 40,
      Red     => 41,
      Green   => 42,
      Yellow  => 43,
      Blue    => 44,
      Magenta => 45,
      Cyan    => 46,
      White   => 47);

   package L renames Ada.Characters.Latin_1;
   package SF renames Ada.Strings.Fixed;

   Reset : constant String := L.ESC & "[0m";

   function Sequence (Code : Natural) return String is
      Image : constant String := SF.Trim (Code'Image, Ada.Strings.Both);
   begin
      return (if Code /= 0 then L.ESC & "[" & Image & "m" else "");
   end Sequence;

   function Colorize (Text : String; Foreground, Background : Color := Default;
                      Attribute : Style := Default) return String is
      FG : constant String := Sequence (Foreground_Color_Codes (Foreground));
      BG : constant String := Sequence (Background_Color_Codes (Background));
      ST : constant String := Sequence (Style_Codes (Attribute));
   begin
      return Reset & FG & BG & ST & Text & Reset;
   end Colorize;

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

   Time_Zero : constant Duration := Orka.OS.Monotonic_Clock;

   Day_In_Seconds : constant := 24.0 * 60.0 * 60.0;

   function Time_Image return String is
      Seconds_Since_Zero : Duration := Orka.OS.Monotonic_Clock - Time_Zero;
      Days_Since_Zero    : Natural := 0;
   begin
      while Seconds_Since_Zero > Day_In_Seconds loop
         Seconds_Since_Zero := Seconds_Since_Zero - Day_In_Seconds;
         Days_Since_Zero    := Days_Since_Zero + 1;
      end loop;

      declare
         Seconds_Rounded : constant Natural :=
           Natural (Duration'Max (0.0, Seconds_Since_Zero - 0.5));

         Hour       : constant Natural := Seconds_Rounded / 3600;
         Minute     : constant Natural := (Seconds_Rounded mod 3600) / 60;
         Second     : constant Natural := Seconds_Rounded mod 60;

         Sub_Second : constant Duration :=
           Seconds_Since_Zero - Duration (Hour * 3600 + Minute * 60 + Second);

         --  Remove first character (space) from ' hhmmss' image and then pad it to six digits
         Image1 : constant String := Natural'Image
           ((Days_Since_Zero * 24 + Hour) * 1e4 + Minute * 1e2 + Second);
         Image2 : constant String := SF.Tail (Image1 (2 .. Image1'Last), 6, '0');

         --  Insert ':' characters to get 'hh:mm:ss'
         Image3 : constant String := SF.Insert (Image2, 5, ":");
         Image4 : constant String := SF.Insert (Image3, 3, ":");

         --  Take image without first character (space) and then pad it to six digits
         Image5 : constant String := Natural'Image (Natural (Sub_Second * 1e6));
         Image6 : constant String := SF.Tail (Image5 (2 .. Image5'Last), 6, '0');
      begin
         return Image4 & "." & Image6;
      end;
   end Time_Image;

   function Format (Value : Duration; Fore, Aft : Positive) return String is
      package SF renames Ada.Strings.Fixed;

      Aft_Shift : constant Positive := 10 ** Aft;
      New_Value : constant Duration := Duration (Natural (Value * Aft_Shift)) / Aft_Shift;

      S1 : constant String := SF.Trim (New_Value'Image, Ada.Strings.Both);

      Index_Decimal : constant Natural := SF.Index (S1, ".");

      --  Following code assumes that Aft >= 1 (If Aft = 0 then Aft must
      --  be decremented to remove the decimal point)
      S2 : constant String := S1 (S1'First .. Natural'Min (S1'Last, Index_Decimal + Aft));
      S3 : constant String := SF.Tail (S2, Natural'Max (S2'Length, Fore + 1 + Aft), ' ');
   begin
      return S3;
   end Format;

   type String_Access is not null access String;

   Suffices : constant array (1 .. 3) of String_Access
     := (new String'("s"),
         new String'("ms"),
         new String'("us"));
   Last_Suffix : constant String_Access := Suffices (Suffices'Last);

   function Image (Value : Duration) return String is
      Number : Duration := Value;

      Suffix : String_Access := Suffices (Suffices'First);
   begin
      for S of Suffices loop
         Suffix := S;
         exit when Number >= 1.0 or else Number <= -1.0 or else S = Last_Suffix;
         Number := Number * 1e3;
      end loop;

      begin
         return Format (Number, Fore => 5, Aft => 3) & " " & Suffix.all;
      exception
         when others =>
            return Number'Image & " " & Suffix.all;
      end;
   end Image;

   function Trim (Value : String) return String renames Orka.Strings.Trim;

   function Strip_Line_Term (Value : String) return String renames Orka.Strings.Strip_Line_Term;

end Orka.Terminals;

orka: Remove usage of Ada.Text_IO.Fixed_IO in package Orka.Terminals

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


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

with Util.Log.Loggers;
with Util.Beans.Objects;
with Util.Files;
with Util.Processes;
with Util.Streams.Pipes;
with Util.Streams.Texts;

with EL.Contexts.TLS;

with Servlet.Core;
with ASF.Requests.Mockup;
with ASF.Responses.Mockup;

with AWA.Applications;
with AWA.Services.Contexts;
with AWA.Modules.Get;
package body AWA.Wikis.Previews is

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("AWA.Wikis.Preview");

   --  ------------------------------
   --  The worker procedure that performs the preview job.
   --  ------------------------------
   procedure Preview_Worker (Job : in out AWA.Jobs.Services.Abstract_Job_Type'Class) is
      Previewer : constant Preview_Module_Access := Get_Preview_Module;
   begin
      Previewer.Do_Preview_Job (Job);
   end Preview_Worker;

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

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

   --  ------------------------------
   --  Configures the module after its initialization and after having read its XML configuration.
   --  ------------------------------
   overriding
   procedure Configure (Plugin : in out Preview_Module;
                        Props  : in ASF.Applications.Config) is
      pragma Unreferenced (Props);
   begin
      Plugin.Template := Plugin.Get_Config (PARAM_PREVIEW_TEMPLATE);
      Plugin.Command := Plugin.Get_Config (PARAM_PREVIEW_COMMAND);
      Plugin.Html := Plugin.Get_Config (PARAM_PREVIEW_HTML);
      Plugin.Add_Listener (AWA.Wikis.Modules.NAME, Plugin'Unchecked_Access);
      Plugin.Job_Module := AWA.Jobs.Modules.Get_Job_Module;
      Plugin.Job_Module.Register (Definition => Preview_Job_Definition.Factory);
   end Configure;

   --  ------------------------------
   --  Execute the preview job and make the thumbnail preview.  The page is first rendered in
   --  an HTML text file and the preview is rendered by using an external command.
   --  ------------------------------
   procedure Do_Preview_Job (Plugin : in Preview_Module;
                             Job    : in out AWA.Jobs.Services.Abstract_Job_Type'Class) is
      pragma Unreferenced (Job);
      use Util.Beans.Objects;

      Ctx       : constant EL.Contexts.ELContext_Access := EL.Contexts.TLS.Current;
      Template  : constant String := To_String (Plugin.Template.Get_Value (Ctx.all));
      Command   : constant String := To_String (Plugin.Command.Get_Value (Ctx.all));
      Html_File : constant String := To_String (Plugin.Html.Get_Value (Ctx.all));
   begin
      Log.Info ("Preview {0} with {1}", Template, Command);
      declare
         Req       : ASF.Requests.Mockup.Request;
         Reply     : ASF.Responses.Mockup.Response;
         Dispatcher : constant Servlet.Core.Request_Dispatcher
           := Plugin.Get_Application.Get_Request_Dispatcher (Template);
         Result : Ada.Strings.Unbounded.Unbounded_String;
      begin
         Req.Set_Request_URI (Template);
         Req.Set_Method ("GET");

         Servlet.Core.Forward (Dispatcher, Req, Reply);
         Reply.Read_Content (Result);
         Util.Files.Write_File (Html_File, Result);
      end;

      declare
         Pipe    : aliased Util.Streams.Pipes.Pipe_Stream;
         Input   : Util.Streams.Texts.Reader_Stream;
      begin
         Log.Info ("Running preview command {0}", Command);

         Pipe.Open (Command, Util.Processes.READ_ALL);
         Input.Initialize (Pipe'Unchecked_Access, 1024);
         while not Input.Is_Eof loop
            declare
               Line : Ada.Strings.Unbounded.Unbounded_String;
            begin
               Input.Read_Line (Line, False);
               Log.Info ("Received: {0}", Line);
            end;
         end loop;
         Pipe.Close;
         if Pipe.Get_Exit_Status /= 0 then
            Log.Error ("Command {0} exited with status {1}", Command,
                       Integer'Image (Pipe.Get_Exit_Status));
         end if;
      end;
   end Do_Preview_Job;

   --  ------------------------------
   --  Create a preview job and schedule the job to generate a new thumbnail preview for the page.
   --  ------------------------------
   procedure Make_Preview_Job (Plugin : in Preview_Module;
                               Page   : in AWA.Wikis.Models.Wiki_Page_Ref'Class) is
      pragma Unreferenced (Plugin);

      J : AWA.Jobs.Services.Job_Type;
   begin
      J.Set_Parameter ("wiki_space_id", Page.Get_Wiki);
      J.Set_Parameter ("wiki_page_id", Page);
      J.Schedule (Preview_Job_Definition.Factory.all);
   end Make_Preview_Job;

   --  ------------------------------
   --  The `On_Create` procedure is called by `Notify_Create` to notify the creation of the page.
   --  ------------------------------
   overriding
   procedure On_Create (Instance : in Preview_Module;
                        Item     : in AWA.Wikis.Models.Wiki_Page_Ref'Class) is
   begin
      Instance.Make_Preview_Job (Item);
   end On_Create;

   --  ------------------------------
   --  The `On_Update` procedure is called by `Notify_Update` to notify the update of the page.
   --  ------------------------------
   overriding
   procedure On_Update (Instance : in Preview_Module;
                        Item     : in AWA.Wikis.Models.Wiki_Page_Ref'Class) is
   begin
      Instance.Make_Preview_Job (Item);
   end On_Update;

   --  ------------------------------
   --  The `On_Delete` procedure is called by `Notify_Delete` to notify the deletion of the page.
   --  ------------------------------
   overriding
   procedure On_Delete (Instance : in Preview_Module;
                        Item     : in AWA.Wikis.Models.Wiki_Page_Ref'Class) is
   begin
      null;
   end On_Delete;

   --  ------------------------------
   --  Get the preview module instance associated with the current application.
   --  ------------------------------
   function Get_Preview_Module return Preview_Module_Access is
      function Get is new AWA.Modules.Get (Preview_Module, Preview_Module_Access, NAME);
   begin
      return Get;
   end Get_Preview_Module;

end AWA.Wikis.Previews;

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

with Util.Log.Loggers;
with Util.Beans.Objects;
with Util.Files;
with Util.Processes;
with Util.Streams.Pipes;
with Util.Streams.Texts;

with EL.Contexts.TLS;

with Servlet.Core;
with ASF.Requests.Mockup;
with ASF.Responses.Mockup;

with AWA.Applications;
with AWA.Modules.Get;
package body AWA.Wikis.Previews is

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("AWA.Wikis.Preview");

   --  ------------------------------
   --  The worker procedure that performs the preview job.
   --  ------------------------------
   procedure Preview_Worker (Job : in out AWA.Jobs.Services.Abstract_Job_Type'Class) is
      Previewer : constant Preview_Module_Access := Get_Preview_Module;
   begin
      Previewer.Do_Preview_Job (Job);
   end Preview_Worker;

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

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

   --  ------------------------------
   --  Configures the module after its initialization and after having read its XML configuration.
   --  ------------------------------
   overriding
   procedure Configure (Plugin : in out Preview_Module;
                        Props  : in ASF.Applications.Config) is
      pragma Unreferenced (Props);
   begin
      Plugin.Template := Plugin.Get_Config (PARAM_PREVIEW_TEMPLATE);
      Plugin.Command := Plugin.Get_Config (PARAM_PREVIEW_COMMAND);
      Plugin.Html := Plugin.Get_Config (PARAM_PREVIEW_HTML);
      Plugin.Add_Listener (AWA.Wikis.Modules.NAME, Plugin'Unchecked_Access);
      Plugin.Job_Module := AWA.Jobs.Modules.Get_Job_Module;
      Plugin.Job_Module.Register (Definition => Preview_Job_Definition.Factory);
   end Configure;

   --  ------------------------------
   --  Execute the preview job and make the thumbnail preview.  The page is first rendered in
   --  an HTML text file and the preview is rendered by using an external command.
   --  ------------------------------
   procedure Do_Preview_Job (Plugin : in Preview_Module;
                             Job    : in out AWA.Jobs.Services.Abstract_Job_Type'Class) is
      pragma Unreferenced (Job);
      use Util.Beans.Objects;

      Ctx       : constant EL.Contexts.ELContext_Access := EL.Contexts.TLS.Current;
      Template  : constant String := To_String (Plugin.Template.Get_Value (Ctx.all));
      Command   : constant String := To_String (Plugin.Command.Get_Value (Ctx.all));
      Html_File : constant String := To_String (Plugin.Html.Get_Value (Ctx.all));
   begin
      Log.Info ("Preview {0} with {1}", Template, Command);
      declare
         Req       : ASF.Requests.Mockup.Request;
         Reply     : ASF.Responses.Mockup.Response;
         Dispatcher : constant Servlet.Core.Request_Dispatcher
           := Plugin.Get_Application.Get_Request_Dispatcher (Template);
         Result : Ada.Strings.Unbounded.Unbounded_String;
      begin
         Req.Set_Request_URI (Template);
         Req.Set_Method ("GET");

         Servlet.Core.Forward (Dispatcher, Req, Reply);
         Reply.Read_Content (Result);
         Util.Files.Write_File (Html_File, Result);
      end;

      declare
         Pipe    : aliased Util.Streams.Pipes.Pipe_Stream;
         Input   : Util.Streams.Texts.Reader_Stream;
      begin
         Log.Info ("Running preview command {0}", Command);

         Pipe.Open (Command, Util.Processes.READ_ALL);
         Input.Initialize (Pipe'Unchecked_Access, 1024);
         while not Input.Is_Eof loop
            declare
               Line : Ada.Strings.Unbounded.Unbounded_String;
            begin
               Input.Read_Line (Line, False);
               Log.Info ("Received: {0}", Line);
            end;
         end loop;
         Pipe.Close;
         if Pipe.Get_Exit_Status /= 0 then
            Log.Error ("Command {0} exited with status {1}", Command,
                       Integer'Image (Pipe.Get_Exit_Status));
         end if;
      end;
   end Do_Preview_Job;

   --  ------------------------------
   --  Create a preview job and schedule the job to generate a new thumbnail preview for the page.
   --  ------------------------------
   procedure Make_Preview_Job (Plugin : in Preview_Module;
                               Page   : in AWA.Wikis.Models.Wiki_Page_Ref'Class) is
      pragma Unreferenced (Plugin);

      J : AWA.Jobs.Services.Job_Type;
   begin
      J.Set_Parameter ("wiki_space_id", Page.Get_Wiki);
      J.Set_Parameter ("wiki_page_id", Page);
      J.Schedule (Preview_Job_Definition.Factory.all);
   end Make_Preview_Job;

   --  ------------------------------
   --  The `On_Create` procedure is called by `Notify_Create` to notify the creation of the page.
   --  ------------------------------
   overriding
   procedure On_Create (Instance : in Preview_Module;
                        Item     : in AWA.Wikis.Models.Wiki_Page_Ref'Class) is
   begin
      Instance.Make_Preview_Job (Item);
   end On_Create;

   --  ------------------------------
   --  The `On_Update` procedure is called by `Notify_Update` to notify the update of the page.
   --  ------------------------------
   overriding
   procedure On_Update (Instance : in Preview_Module;
                        Item     : in AWA.Wikis.Models.Wiki_Page_Ref'Class) is
   begin
      Instance.Make_Preview_Job (Item);
   end On_Update;

   --  ------------------------------
   --  The `On_Delete` procedure is called by `Notify_Delete` to notify the deletion of the page.
   --  ------------------------------
   overriding
   procedure On_Delete (Instance : in Preview_Module;
                        Item     : in AWA.Wikis.Models.Wiki_Page_Ref'Class) is
   begin
      null;
   end On_Delete;

   --  ------------------------------
   --  Get the preview module instance associated with the current application.
   --  ------------------------------
   function Get_Preview_Module return Preview_Module_Access is
      function Get is new AWA.Modules.Get (Preview_Module, Preview_Module_Access, NAME);
   begin
      return Get;
   end Get_Preview_Module;

end AWA.Wikis.Previews;

Fix compilation warning

Fix compilation warning


-----------------------------------------------------------------------
--  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 Util.Strings;
package body MAT.Formats is

   use type MAT.Types.Target_Tick_Ref;

   Hex_Prefix : Boolean := True;

   Conversion : constant String (1 .. 10) := "0123456789";

   function Location (File : in Ada.Strings.Unbounded.Unbounded_String) return String;

   function Event_Malloc (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;

   function Event_Free (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;

   --  ------------------------------
   --  Format the address into a string.
   --  ------------------------------
   function Addr (Value : in MAT.Types.Target_Addr) return String is
      Hex : constant String := MAT.Types.Hex_Image (Value);
   begin
      if Hex_Prefix then
         return "0x" & Hex;
      else
         return Hex;
      end if;
   end Addr;

   --  ------------------------------
   --  Format the size into a string.
   --  ------------------------------
   function Size (Value : in MAT.Types.Target_Size) return String is
      Result : constant String := MAT.Types.Target_Size'Image (Value);
   begin
      if Result (Result'First) = ' ' then
         return Result (Result'First + 1 .. Result'Last);
      else
         return Result;
      end if;
   end Size;

   --  ------------------------------
   --  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 is
      T    : constant MAT.Types.Target_Tick_Ref := Value - Start;
      Sec  : constant MAT.Types.Target_Tick_Ref := T / 1_000_000;
      Usec : constant MAT.Types.Target_Tick_Ref := T mod 1_000_000;
      Msec : Natural := Natural (Usec / 1_000);
      Frac : String (1 .. 5);
   begin
      Frac (5) := 's';
      Frac (4) := Conversion (Msec mod 10 + 1);
      Msec := Msec / 10;
      Frac (3) := Conversion (Msec mod 10 + 1);
      Msec := Msec / 10;
      Frac (2) := Conversion (Msec mod 10 + 1);
      Frac (1) := '.';
      return MAT.Types.Target_Tick_Ref'Image (Sec) & Frac;
   end Time;

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

      Sec  : constant MAT.Types.Target_Tick_Ref := Value / 1_000_000;
      Usec : constant MAT.Types.Target_Tick_Ref := Value mod 1_000_000;
      Msec : constant Natural := Natural (Usec / 1_000);
      Val  : Natural;
      Frac : String (1 .. 5);
   begin
      if Sec = 0 and Msec = 0 then
         return Util.Strings.Image (Integer (Usec)) & "us";
      elsif Sec = 0 then
         Val := Natural (Usec mod 1_000);
         Frac (5) := 's';
         Frac (4) := 'm';
         Frac (3) := Conversion (Val mod 10 + 1);
         Val := Val / 10;
         Frac (3) := Conversion (Val mod 10 + 1);
         Val := Val / 10;
         Frac (2) := Conversion (Val mod 10 + 1);
         Frac (1) := '.';
         return Util.Strings.Image (Integer (Msec)) & Frac;
      else
         Val := Msec;
         Frac (4) := 's';
         Frac (3) := Conversion (Val mod 10 + 1);
         Val := Val / 10;
         Frac (3) := Conversion (Val mod 10 + 1);
         Val := Val / 10;
         Frac (2) := Conversion (Val mod 10 + 1);
         Frac (1) := '.';
         return Util.Strings.Image (Integer (Msec)) & Frac (1 .. 4);
      end if;
   end Duration;

   function Location (File : in Ada.Strings.Unbounded.Unbounded_String) return String is
      Pos : constant Natural := Ada.Strings.Unbounded.Index (File, "/", Ada.Strings.Backward);
      Len : constant Natural := Ada.Strings.Unbounded.Length (File);
   begin
      if Pos /= 0 then
         return Ada.Strings.Unbounded.Slice (File, Pos + 1, Len);
      else
         return Ada.Strings.Unbounded.To_String (File);
      end if;
   end Location;

   --  ------------------------------
   --  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 is
   begin
      if Ada.Strings.Unbounded.Length (File) = 0 then
         return Ada.Strings.Unbounded.To_String (Func);
      elsif Line > 0 then
         declare
            Num : constant String := Natural'Image (Line);
         begin
            return Ada.Strings.Unbounded.To_String (Func) & " ("
              & Location (File) & ":" & Num (Num'First + 1 .. Num'Last) & ")";
         end;
      else
         return Ada.Strings.Unbounded.To_String (Func) & " (" & Location (File) & ")";
      end if;
   end Location;

   --  ------------------------------
   --  Format a short description of the event.
   --  ------------------------------
   function Event (Item : in MAT.Events.Targets.Probe_Event_Type) return String is
      use type MAT.Types.Target_Addr;
   begin
      case Item.Index is
         when MAT.Events.Targets.MSG_MALLOC =>
            return "malloc(" & Size (Item.Size) & ") = " & Addr (Item.Addr);

         when MAT.Events.Targets.MSG_REALLOC =>
            if Item.Old_Addr = 0 then
               return "realloc(0," & Size (Item.Size) & ") = "
                 & Addr (Item.Addr);
            else
               return "realloc(" & Addr (Item.Old_Addr) & "," & Size (Item.Size) & ") = "
                 & Addr (Item.Addr);
            end if;

         when MAT.Events.Targets.MSG_FREE =>
            return "free(" & Addr (Item.Addr) & ")";

         when MAT.Events.Targets.MSG_BEGIN =>
            return "begin";

         when MAT.Events.Targets.MSG_END =>
            return "end";

         when MAT.Events.Targets.MSG_LIBRARY =>
            return "library";

      end case;
   end Event;

   function Event_Malloc (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 is
      Free_Event : MAT.Events.Targets.Probe_Event_Type;
   begin
      Free_Event := MAT.Events.Targets.Find (Related, MAT.Events.Targets.MSG_FREE);

      return Size (Item.Size) & " bytes allocated after " & Duration (Item.Time - Start_Time)
        & ", freed " & Duration (Free_Event.Time - Item.Time)
        & " after by event" & MAT.Events.Targets.Event_Id_Type'Image (Free_Event.Id)
      ;

   exception
      when MAT.Events.Targets.Not_Found =>
         return Size (Item.Size) & " bytes allocated (never freed)";

   end Event_Malloc;

   function Event_Free (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 is
      Alloc_Event : MAT.Events.Targets.Probe_Event_Type;
   begin
      Alloc_Event := MAT.Events.Targets.Find (Related, MAT.Events.Targets.MSG_MALLOC);

      return Size (Alloc_Event.Size) & " bytes freed after " & Duration (Item.Time - Start_Time)
        & ", alloc'ed for " & Duration (Item.Time - Alloc_Event.Time)
        & " by event" & MAT.Events.Targets.Event_Id_Type'Image (Alloc_Event.Id);

   exception
      when MAT.Events.Targets.Not_Found =>
         return Size (Item.Size) & " bytes freed";

   end Event_Free;

   --  ------------------------------
   --  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 is
   begin
      case Item.Index is
         when MAT.Events.Targets.MSG_MALLOC =>
            return Event_Malloc (Item, Related, Start_Time);

         when MAT.Events.Targets.MSG_REALLOC =>
            return Size (Item.Size) & " bytes reallocated";

         when MAT.Events.Targets.MSG_FREE =>
            return Event_Free (Item, Related, Start_Time);

         when MAT.Events.Targets.MSG_BEGIN =>
            return "Begin event";

         when MAT.Events.Targets.MSG_END =>
            return "End event";

         when MAT.Events.Targets.MSG_LIBRARY =>
            return "Library information event";

      end case;
   end Event;

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 Util.Strings;
package body MAT.Formats is

   use type MAT.Types.Target_Tick_Ref;

   Hex_Prefix : Boolean := True;

   Conversion : constant String (1 .. 10) := "0123456789";

   function Location (File : in Ada.Strings.Unbounded.Unbounded_String) return String;

   function Event_Malloc (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;

   function Event_Free (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;

   --  ------------------------------
   --  Format the address into a string.
   --  ------------------------------
   function Addr (Value : in MAT.Types.Target_Addr) return String is
      Hex : constant String := MAT.Types.Hex_Image (Value);
   begin
      if Hex_Prefix then
         return "0x" & Hex;
      else
         return Hex;
      end if;
   end Addr;

   --  ------------------------------
   --  Format the size into a string.
   --  ------------------------------
   function Size (Value : in MAT.Types.Target_Size) return String is
      Result : constant String := MAT.Types.Target_Size'Image (Value);
   begin
      if Result (Result'First) = ' ' then
         return Result (Result'First + 1 .. Result'Last);
      else
         return Result;
      end if;
   end Size;

   --  ------------------------------
   --  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 is
      T    : constant MAT.Types.Target_Tick_Ref := Value - Start;
      Sec  : constant MAT.Types.Target_Tick_Ref := T / 1_000_000;
      Usec : constant MAT.Types.Target_Tick_Ref := T mod 1_000_000;
      Msec : Natural := Natural (Usec / 1_000);
      Frac : String (1 .. 5);
   begin
      Frac (5) := 's';
      Frac (4) := Conversion (Msec mod 10 + 1);
      Msec := Msec / 10;
      Frac (3) := Conversion (Msec mod 10 + 1);
      Msec := Msec / 10;
      Frac (2) := Conversion (Msec mod 10 + 1);
      Frac (1) := '.';
      return MAT.Types.Target_Tick_Ref'Image (Sec) & Frac;
   end Time;

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

      Sec  : constant MAT.Types.Target_Tick_Ref := Value / 1_000_000;
      Usec : constant MAT.Types.Target_Tick_Ref := Value mod 1_000_000;
      Msec : constant Natural := Natural (Usec / 1_000);
      Val  : Natural;
      Frac : String (1 .. 5);
   begin
      if Sec = 0 and Msec = 0 then
         return Util.Strings.Image (Integer (Usec)) & "us";
      elsif Sec = 0 then
         Val := Natural (Usec mod 1_000);
         Frac (5) := 's';
         Frac (4) := 'm';
         Frac (3) := Conversion (Val mod 10 + 1);
         Val := Val / 10;
         Frac (3) := Conversion (Val mod 10 + 1);
         Val := Val / 10;
         Frac (2) := Conversion (Val mod 10 + 1);
         Frac (1) := '.';
         return Util.Strings.Image (Integer (Msec)) & Frac;
      else
         Val := Msec;
         Frac (4) := 's';
         Frac (3) := Conversion (Val mod 10 + 1);
         Val := Val / 10;
         Frac (3) := Conversion (Val mod 10 + 1);
         Val := Val / 10;
         Frac (2) := Conversion (Val mod 10 + 1);
         Frac (1) := '.';
         return Util.Strings.Image (Integer (Msec)) & Frac (1 .. 4);
      end if;
   end Duration;

   function Location (File : in Ada.Strings.Unbounded.Unbounded_String) return String is
      Pos : constant Natural := Ada.Strings.Unbounded.Index (File, "/", Ada.Strings.Backward);
      Len : constant Natural := Ada.Strings.Unbounded.Length (File);
   begin
      if Pos /= 0 then
         return Ada.Strings.Unbounded.Slice (File, Pos + 1, Len);
      else
         return Ada.Strings.Unbounded.To_String (File);
      end if;
   end Location;

   --  ------------------------------
   --  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 is
   begin
      if Ada.Strings.Unbounded.Length (File) = 0 then
         return Ada.Strings.Unbounded.To_String (Func);
      elsif Line > 0 then
         declare
            Num : constant String := Natural'Image (Line);
         begin
            return Ada.Strings.Unbounded.To_String (Func) & " ("
              & Location (File) & ":" & Num (Num'First + 1 .. Num'Last) & ")";
         end;
      else
         return Ada.Strings.Unbounded.To_String (Func) & " (" & Location (File) & ")";
      end if;
   end Location;

   --  ------------------------------
   --  Format a short description of the event.
   --  ------------------------------
   function Event (Item : in MAT.Events.Targets.Probe_Event_Type;
                   Mode : in Format_Type := NORMAL) return String is
      use type MAT.Types.Target_Addr;
   begin
      case Item.Index is
         when MAT.Events.Targets.MSG_MALLOC =>
            if Mode = BRIEF then
               return "malloc(" & Size (Item.Size) & ")";
            else
               return "malloc(" & Size (Item.Size) & ") = " & Addr (Item.Addr);
            end if;

         when MAT.Events.Targets.MSG_REALLOC =>
            if Mode = BRIEF then
               if Item.Old_Addr = 0 then
                  return "realloc(0," & Size (Item.Size) & ")";
               else
                  return "realloc(" & Addr (Item.Old_Addr) & "," & Size (Item.Size) & ")";
               end if;
            else
               if Item.Old_Addr = 0 then
                  return "realloc(0," & Size (Item.Size) & ") = "
                    & Addr (Item.Addr);
               else
                  return "realloc(" & Addr (Item.Old_Addr) & "," & Size (Item.Size) & ") = "
                    & Addr (Item.Addr);
               end if;
            end if;

         when MAT.Events.Targets.MSG_FREE =>
            return "free(" & Addr (Item.Addr) & ")";

         when MAT.Events.Targets.MSG_BEGIN =>
            return "begin";

         when MAT.Events.Targets.MSG_END =>
            return "end";

         when MAT.Events.Targets.MSG_LIBRARY =>
            return "library";

      end case;
   end Event;

   function Event_Malloc (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 is
      Free_Event : MAT.Events.Targets.Probe_Event_Type;
   begin
      Free_Event := MAT.Events.Targets.Find (Related, MAT.Events.Targets.MSG_FREE);

      return Size (Item.Size) & " bytes allocated after " & Duration (Item.Time - Start_Time)
        & ", freed " & Duration (Free_Event.Time - Item.Time)
        & " after by event" & MAT.Events.Targets.Event_Id_Type'Image (Free_Event.Id)
      ;

   exception
      when MAT.Events.Targets.Not_Found =>
         return Size (Item.Size) & " bytes allocated (never freed)";

   end Event_Malloc;

   function Event_Free (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 is
      Alloc_Event : MAT.Events.Targets.Probe_Event_Type;
   begin
      Alloc_Event := MAT.Events.Targets.Find (Related, MAT.Events.Targets.MSG_MALLOC);

      return Size (Alloc_Event.Size) & " bytes freed after " & Duration (Item.Time - Start_Time)
        & ", alloc'ed for " & Duration (Item.Time - Alloc_Event.Time)
        & " by event" & MAT.Events.Targets.Event_Id_Type'Image (Alloc_Event.Id);

   exception
      when MAT.Events.Targets.Not_Found =>
         return Size (Item.Size) & " bytes freed";

   end Event_Free;

   --  ------------------------------
   --  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 is
   begin
      case Item.Index is
         when MAT.Events.Targets.MSG_MALLOC =>
            return Event_Malloc (Item, Related, Start_Time);

         when MAT.Events.Targets.MSG_REALLOC =>
            return Size (Item.Size) & " bytes reallocated";

         when MAT.Events.Targets.MSG_FREE =>
            return Event_Free (Item, Related, Start_Time);

         when MAT.Events.Targets.MSG_BEGIN =>
            return "Begin event";

         when MAT.Events.Targets.MSG_END =>
            return "End event";

         when MAT.Events.Targets.MSG_LIBRARY =>
            return "Library information event";

      end case;
   end Event;

end MAT.Formats;

Add a brief or normal format type for events to print short description of malloc/realloc events


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

with Ada.Directories;
with Ada.Unchecked_Deallocation;

package body Util.Processes.Os is

   use Util.Systems.Os;
   use type Interfaces.C.size_t;
   use type Util.Systems.Types.File_Type;
   use type Ada.Directories.File_Kind;

   type Pipe_Type is array (0 .. 1) of File_Type;
   procedure Close (Pipes : in out Pipe_Type);

   --  ------------------------------
   --  Create the output stream to read/write on the process input/output.
   --  Setup the file to be closed on exec.
   --  ------------------------------
   function Create_Stream (File : in File_Type)
                           return Util.Streams.Raw.Raw_Stream_Access is
      Stream : constant Util.Streams.Raw.Raw_Stream_Access := new Util.Streams.Raw.Raw_Stream;
      Status : constant Integer := Sys_Fcntl (File, F_SETFL, FD_CLOEXEC);
      pragma Unreferenced (Status);
   begin
      Stream.Initialize (File);
      return Stream;
   end Create_Stream;

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

      use type Util.Streams.Output_Stream_Access;

      Result : Integer;
      Wpid   : Integer;
   begin
      --  Close the input stream pipe if there is one.
      if Proc.Input /= null then
         Util.Streams.Raw.Raw_Stream'Class (Proc.Input.all).Close;
      end if;

      Wpid := Sys_Waitpid (Integer (Proc.Pid), Result'Address, 0);
      if Wpid = Integer (Proc.Pid) then
         Proc.Exit_Value := Result / 256;
         if Result mod 256 /= 0 then
            Proc.Exit_Value := (Result mod 256) * 1000;
         end if;
      end if;
   end Wait;

   --  ------------------------------
   --  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.
   --  ------------------------------
   overriding
   procedure Stop (Sys    : in out System_Process;
                   Proc   : in out Process'Class;
                   Signal : in Positive := 15) is
      pragma Unreferenced (Sys);
      Result : Integer;
      pragma Unreferenced (Result);
   begin
      Result := Sys_Kill (Integer (Proc.Pid), Integer (Signal));
   end Stop;

   --  ------------------------------
   --  Close both ends of the pipe (used to cleanup in case or error).
   --  ------------------------------
   procedure Close (Pipes : in out Pipe_Type) is
      Result : Integer;
      pragma Unreferenced (Result);
   begin
      if Pipes (0) /= NO_FILE then
         Result := Sys_Close (Pipes (0));
         Pipes (0) := NO_FILE;
      end if;
      if Pipes (1) /= NO_FILE then
         Result := Sys_Close (Pipes (1));
         Pipes (1) := NO_FILE;
      end if;
   end Close;

   procedure Prepare_Working_Directory (Sys : in out System_Process;
                                        Proc : in out Process'Class) is
      Dir : constant String := Ada.Strings.Unbounded.To_String (Proc.Dir);
   begin
      Interfaces.C.Strings.Free (Sys.Dir);
      if Dir'Length > 0 then
         if not Ada.Directories.Exists (Dir)
           or else Ada.Directories.Kind (Dir) /= Ada.Directories.Directory then
            raise Ada.Directories.Name_Error with "Invalid directory: " & Dir;
         end if;
         Sys.Dir := Interfaces.C.Strings.New_String (Dir);
      end if;
   end Prepare_Working_Directory;

   --  ------------------------------
   --  Spawn a new process.
   --  ------------------------------
   overriding
   procedure Spawn (Sys  : in out System_Process;
                    Proc : in out Process'Class;
                    Mode : in Pipe_Mode := NONE) is
      use Interfaces.C.Strings;
      use type Interfaces.C.int;

      procedure Cleanup;

      --  Suppress all checks to make sure the child process will not raise any exception.
      pragma Suppress (All_Checks);

      Result : Integer;
      pragma Unreferenced (Result);

      Stdin_Pipes   : aliased Pipe_Type := (others => NO_FILE);
      Stdout_Pipes  : aliased Pipe_Type := (others => NO_FILE);
      Stderr_Pipes  : aliased Pipe_Type := (others => NO_FILE);

      procedure Cleanup is
      begin
         Close (Stdin_Pipes);
         Close (Stdout_Pipes);
         Close (Stderr_Pipes);
      end Cleanup;

   begin
      Sys.Prepare_Working_Directory (Proc);

      --  Since checks are disabled, verify by hand that the argv table is correct.
      if Sys.Argv = null or else Sys.Argc < 1 or else Sys.Argv (0) = Null_Ptr then
         raise Program_Error with "Invalid process argument list";
      end if;

      --  Setup the pipes.
      if Mode = READ or Mode = READ_WRITE or Mode = READ_ALL then
         if Sys_Pipe (Stdout_Pipes'Address) /= 0 then
            raise Process_Error with "Cannot create stdout pipe";
         end if;
      end if;
      if Mode = WRITE or Mode = READ_WRITE or Mode = READ_WRITE_ALL then
         if Sys_Pipe (Stdin_Pipes'Address) /= 0 then
            Cleanup;
            raise Process_Error with "Cannot create stdin pipe";
         end if;
      end if;
      if Mode = READ_ERROR then
         if Sys_Pipe (Stderr_Pipes'Address) /= 0 then
            Cleanup;
            raise Process_Error with "Cannot create stderr pipe";
         end if;
      end if;

      --  Create the new process by using vfork instead of fork.  The parent process is blocked
      --  until the child executes the exec or exits.  The child process uses the same stack
      --  as the parent.
      Proc.Pid := Sys_VFork;
      if Proc.Pid = 0 then

         --  Do not use any Ada type while in the child process.

         if Proc.To_Close /= null then
            for Fd of Proc.To_Close.all loop
               Result := Sys_Close (Fd);
            end loop;
         end if;

         if Mode = READ_ALL or Mode = READ_WRITE_ALL then
            Result := Sys_Dup2 (Stdout_Pipes (1), STDERR_FILENO);
         end if;

         if Stderr_Pipes (1) /= NO_FILE then
            if Stderr_Pipes (1) /= STDERR_FILENO then
               Result := Sys_Dup2 (Stderr_Pipes (1), STDERR_FILENO);
               Result := Sys_Close (Stderr_Pipes (1));
            end if;
            Result := Sys_Close (Stderr_Pipes (0));

         elsif Sys.Err_File /= Null_Ptr then
            --  Redirect the process error to a file.
            declare
               Fd : File_Type;
            begin
               if Sys.Err_Append then
                  Fd := Sys_Open (Sys.Err_File, O_CREAT + O_WRONLY + O_APPEND, 8#644#);
               else
                  Fd := Sys_Open (Sys.Err_File, O_CREAT + O_WRONLY + O_TRUNC, 8#644#);
               end if;
               if Fd < 0 then
                  Sys_Exit (254);
               end if;
               Result := Sys_Dup2 (Fd, STDOUT_FILENO);
               Result := Sys_Close (Fd);
            end;
         end if;

         if Stdout_Pipes (1) /= NO_FILE then
            if Stdout_Pipes (1) /= STDOUT_FILENO then
               Result := Sys_Dup2 (Stdout_Pipes (1), STDOUT_FILENO);
               Result := Sys_Close (Stdout_Pipes (1));
            end if;
            Result := Sys_Close (Stdout_Pipes (0));

         elsif Sys.Out_File /= Null_Ptr then
            --  Redirect the process output to a file.
            declare
               Fd : File_Type;
            begin
               if Sys.Out_Append then
                  Fd := Sys_Open (Sys.Out_File, O_CREAT + O_WRONLY + O_APPEND, 8#644#);
               else
                  Fd := Sys_Open (Sys.Out_File, O_CREAT + O_WRONLY + O_TRUNC, 8#644#);
               end if;
               if Fd < 0 then
                  Sys_Exit (254);
               end if;
               Result := Sys_Dup2 (Fd, STDOUT_FILENO);
               Result := Sys_Close (Fd);
            end;
         end if;

         if Stdin_Pipes (0) /= NO_FILE then
            if Stdin_Pipes (0) /= STDIN_FILENO then
               Result := Sys_Dup2 (Stdin_Pipes (0), STDIN_FILENO);
               Result := Sys_Close (Stdin_Pipes (0));
            end if;
            Result := Sys_Close (Stdin_Pipes (1));

         elsif Sys.In_File /= Null_Ptr then
            --  Redirect the process input from a file.
            declare
               Fd : File_Type;
            begin
               Fd := Sys_Open (Sys.In_File, O_RDONLY, 8#644#);
               if Fd < 0 then
                  Sys_Exit (254);
               end if;
               Result := Sys_Dup2 (Fd, STDIN_FILENO);
               Result := Sys_Close (Fd);
            end;
         end if;

         if Sys.Dir /= Null_Ptr then
            Result := Sys_Chdir (Sys.Dir);
            if Result < 0 then
               Sys_Exit (253);
            end if;
         end if;

         Result := Sys_Execvp (Sys.Argv (0), Sys.Argv.all);
         Sys_Exit (255);
      end if;

      --  Process creation failed, cleanup and raise an exception.
      if Proc.Pid < 0 then
         Cleanup;
         raise Process_Error with "Cannot create process";
      end if;

      if Stdin_Pipes (1) /= NO_FILE then
         Result := Sys_Close (Stdin_Pipes (0));
         Proc.Input := Create_Stream (Stdin_Pipes (1)).all'Access;
      end if;

      if Stdout_Pipes (0) /= NO_FILE then
         Result := Sys_Close (Stdout_Pipes (1));
         Proc.Output := Create_Stream (Stdout_Pipes (0)).all'Access;
      end if;

      if Stderr_Pipes (0) /= NO_FILE then
         Result := Sys_Close (Stderr_Pipes (1));
         Proc.Error := Create_Stream (Stderr_Pipes (0)).all'Access;
      end if;

   end Spawn;

   procedure Free is
     new Ada.Unchecked_Deallocation (Name => Ptr_Ptr_Array, Object => Ptr_Array);

   --  ------------------------------
   --  Append the argument to the process argument list.
   --  ------------------------------
   overriding
   procedure Append_Argument (Sys : in out System_Process;
                              Arg : in String) is
   begin
      if Sys.Argv = null then
         Sys.Argv := new Ptr_Array (0 .. 10);
      elsif Sys.Argc = Sys.Argv'Last - 1 then
         declare
            N : constant Ptr_Ptr_Array := new Ptr_Array (0 .. Sys.Argc + 32);
         begin
            N (0 .. Sys.Argc) := Sys.Argv (0 .. Sys.Argc);
            Free (Sys.Argv);
            Sys.Argv := N;
         end;
      end if;

      Sys.Argv (Sys.Argc) := Interfaces.C.Strings.New_String (Arg);
      Sys.Argc := Sys.Argc + 1;
      Sys.Argv (Sys.Argc) := Interfaces.C.Strings.Null_Ptr;
   end Append_Argument;

   --  ------------------------------
   --  Set the process input, output and error streams to redirect and use specified files.
   --  ------------------------------
   overriding
   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
   begin
      if Input'Length > 0 then
         Sys.In_File := Interfaces.C.Strings.New_String (Input);
      end if;
      if Output'Length > 0 then
         Sys.Out_File   := Interfaces.C.Strings.New_String (Output);
         Sys.Out_Append := Append_Output;
      end if;
      if Error'Length > 0 then
         Sys.Err_File   := Interfaces.C.Strings.New_String (Error);
         Sys.Err_Append := Append_Error;
      end if;
      Sys.To_Close := To_Close;
   end Set_Streams;

   --  ------------------------------
   --  Deletes the storage held by the system process.
   --  ------------------------------
   overriding
   procedure Finalize (Sys : in out System_Process) is
   begin
      if Sys.Argv /= null then
         for I in Sys.Argv'Range loop
            Interfaces.C.Strings.Free (Sys.Argv (I));
         end loop;
         Free (Sys.Argv);
      end if;
      Interfaces.C.Strings.Free (Sys.In_File);
      Interfaces.C.Strings.Free (Sys.Out_File);
      Interfaces.C.Strings.Free (Sys.Err_File);
      Interfaces.C.Strings.Free (Sys.Dir);
   end Finalize;

end Util.Processes.Os;

-----------------------------------------------------------------------
--  util-processes-os -- System specific and low level operations
--  Copyright (C) 2011, 2012, 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 Ada.Directories;
with Ada.Unchecked_Deallocation;

package body Util.Processes.Os is

   use Util.Systems.Os;
   use type Interfaces.C.size_t;
   use type Util.Systems.Types.File_Type;
   use type Ada.Directories.File_Kind;

   type Pipe_Type is array (0 .. 1) of File_Type;
   procedure Close (Pipes : in out Pipe_Type);

   --  ------------------------------
   --  Create the output stream to read/write on the process input/output.
   --  Setup the file to be closed on exec.
   --  ------------------------------
   function Create_Stream (File : in File_Type)
                           return Util.Streams.Raw.Raw_Stream_Access is
      Stream : constant Util.Streams.Raw.Raw_Stream_Access := new Util.Streams.Raw.Raw_Stream;
      Status : constant Integer := Sys_Fcntl (File, F_SETFL, FD_CLOEXEC);
      pragma Unreferenced (Status);
   begin
      Stream.Initialize (File);
      return Stream;
   end Create_Stream;

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

      use type Util.Streams.Output_Stream_Access;

      Result : Integer;
      Wpid   : Integer;
   begin
      --  Close the input stream pipe if there is one.
      if Proc.Input /= null then
         Util.Streams.Raw.Raw_Stream'Class (Proc.Input.all).Close;
      end if;

      Wpid := Sys_Waitpid (Integer (Proc.Pid), Result'Address, 0);
      if Wpid = Integer (Proc.Pid) then
         Proc.Exit_Value := Result / 256;
         if Result mod 256 /= 0 then
            Proc.Exit_Value := (Result mod 256) * 1000;
         end if;
      end if;
   end Wait;

   --  ------------------------------
   --  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.
   --  ------------------------------
   overriding
   procedure Stop (Sys    : in out System_Process;
                   Proc   : in out Process'Class;
                   Signal : in Positive := 15) is
      pragma Unreferenced (Sys);
      Result : Integer;
      pragma Unreferenced (Result);
   begin
      Result := Sys_Kill (Integer (Proc.Pid), Integer (Signal));
   end Stop;

   --  ------------------------------
   --  Close both ends of the pipe (used to cleanup in case or error).
   --  ------------------------------
   procedure Close (Pipes : in out Pipe_Type) is
      Result : Integer;
      pragma Unreferenced (Result);
   begin
      if Pipes (0) /= NO_FILE then
         Result := Sys_Close (Pipes (0));
         Pipes (0) := NO_FILE;
      end if;
      if Pipes (1) /= NO_FILE then
         Result := Sys_Close (Pipes (1));
         Pipes (1) := NO_FILE;
      end if;
   end Close;

   procedure Prepare_Working_Directory (Sys : in out System_Process;
                                        Proc : in out Process'Class) is
      Dir : constant String := Ada.Strings.Unbounded.To_String (Proc.Dir);
   begin
      Interfaces.C.Strings.Free (Sys.Dir);
      if Dir'Length > 0 then
         if not Ada.Directories.Exists (Dir)
           or else Ada.Directories.Kind (Dir) /= Ada.Directories.Directory
         then
            raise Ada.Directories.Name_Error with "Invalid directory: " & Dir;
         end if;
         Sys.Dir := Interfaces.C.Strings.New_String (Dir);
      end if;
   end Prepare_Working_Directory;

   --  ------------------------------
   --  Spawn a new process.
   --  ------------------------------
   overriding
   procedure Spawn (Sys  : in out System_Process;
                    Proc : in out Process'Class;
                    Mode : in Pipe_Mode := NONE) is
      use Interfaces.C.Strings;
      use type Interfaces.C.int;

      procedure Cleanup;

      --  Suppress all checks to make sure the child process will not raise any exception.
      pragma Suppress (All_Checks);

      Result : Integer;

      Stdin_Pipes   : aliased Pipe_Type := (others => NO_FILE);
      Stdout_Pipes  : aliased Pipe_Type := (others => NO_FILE);
      Stderr_Pipes  : aliased Pipe_Type := (others => NO_FILE);

      procedure Cleanup is
      begin
         Close (Stdin_Pipes);
         Close (Stdout_Pipes);
         Close (Stderr_Pipes);
      end Cleanup;

   begin
      Sys.Prepare_Working_Directory (Proc);

      --  Since checks are disabled, verify by hand that the argv table is correct.
      if Sys.Argv = null or else Sys.Argc < 1 or else Sys.Argv (0) = Null_Ptr then
         raise Program_Error with "Invalid process argument list";
      end if;

      --  Setup the pipes.
      if Mode = READ or Mode = READ_WRITE or Mode = READ_ALL then
         if Sys_Pipe (Stdout_Pipes'Address) /= 0 then
            raise Process_Error with "Cannot create stdout pipe";
         end if;
      end if;
      if Mode = WRITE or Mode = READ_WRITE or Mode = READ_WRITE_ALL then
         if Sys_Pipe (Stdin_Pipes'Address) /= 0 then
            Cleanup;
            raise Process_Error with "Cannot create stdin pipe";
         end if;
      end if;
      if Mode = READ_ERROR then
         if Sys_Pipe (Stderr_Pipes'Address) /= 0 then
            Cleanup;
            raise Process_Error with "Cannot create stderr pipe";
         end if;
      end if;

      --  Create the new process by using vfork instead of fork.  The parent process is blocked
      --  until the child executes the exec or exits.  The child process uses the same stack
      --  as the parent.
      Proc.Pid := Sys_VFork;
      if Proc.Pid = 0 then

         --  Do not use any Ada type while in the child process.

         if Proc.To_Close /= null then
            for Fd of Proc.To_Close.all loop
               Result := Sys_Close (Fd);
            end loop;
         end if;

         if Mode = READ_ALL or Mode = READ_WRITE_ALL then
            Result := Sys_Dup2 (Stdout_Pipes (1), STDERR_FILENO);
         end if;

         if Stderr_Pipes (1) /= NO_FILE then
            if Stderr_Pipes (1) /= STDERR_FILENO then
               Result := Sys_Dup2 (Stderr_Pipes (1), STDERR_FILENO);
               Result := Sys_Close (Stderr_Pipes (1));
            end if;
            Result := Sys_Close (Stderr_Pipes (0));

         elsif Sys.Err_File /= Null_Ptr then
            --  Redirect the process error to a file.
            declare
               Fd : File_Type;
            begin
               if Sys.Err_Append then
                  Fd := Sys_Open (Sys.Err_File, O_CREAT + O_WRONLY + O_APPEND, 8#644#);
               else
                  Fd := Sys_Open (Sys.Err_File, O_CREAT + O_WRONLY + O_TRUNC, 8#644#);
               end if;
               if Fd < 0 then
                  Sys_Exit (254);
               end if;
               Result := Sys_Dup2 (Fd, STDOUT_FILENO);
               Result := Sys_Close (Fd);
            end;
         end if;

         if Stdout_Pipes (1) /= NO_FILE then
            if Stdout_Pipes (1) /= STDOUT_FILENO then
               Result := Sys_Dup2 (Stdout_Pipes (1), STDOUT_FILENO);
               Result := Sys_Close (Stdout_Pipes (1));
            end if;
            Result := Sys_Close (Stdout_Pipes (0));

         elsif Sys.Out_File /= Null_Ptr then
            --  Redirect the process output to a file.
            declare
               Fd : File_Type;
            begin
               if Sys.Out_Append then
                  Fd := Sys_Open (Sys.Out_File, O_CREAT + O_WRONLY + O_APPEND, 8#644#);
               else
                  Fd := Sys_Open (Sys.Out_File, O_CREAT + O_WRONLY + O_TRUNC, 8#644#);
               end if;
               if Fd < 0 then
                  Sys_Exit (254);
               end if;
               Result := Sys_Dup2 (Fd, STDOUT_FILENO);
               Result := Sys_Close (Fd);
            end;
         end if;

         if Stdin_Pipes (0) /= NO_FILE then
            if Stdin_Pipes (0) /= STDIN_FILENO then
               Result := Sys_Dup2 (Stdin_Pipes (0), STDIN_FILENO);
               Result := Sys_Close (Stdin_Pipes (0));
            end if;
            Result := Sys_Close (Stdin_Pipes (1));

         elsif Sys.In_File /= Null_Ptr then
            --  Redirect the process input from a file.
            declare
               Fd : File_Type;
            begin
               Fd := Sys_Open (Sys.In_File, O_RDONLY, 8#644#);
               if Fd < 0 then
                  Sys_Exit (254);
               end if;
               Result := Sys_Dup2 (Fd, STDIN_FILENO);
               Result := Sys_Close (Fd);
            end;
         end if;

         if Sys.Dir /= Null_Ptr then
            Result := Sys_Chdir (Sys.Dir);
            if Result < 0 then
               Sys_Exit (253);
            end if;
         end if;

         Result := Sys_Execvp (Sys.Argv (0), Sys.Argv.all);
         Sys_Exit (255);
      end if;

      --  Process creation failed, cleanup and raise an exception.
      if Proc.Pid < 0 then
         Cleanup;
         raise Process_Error with "Cannot create process";
      end if;

      if Stdin_Pipes (1) /= NO_FILE then
         Result := Sys_Close (Stdin_Pipes (0));
         Proc.Input := Create_Stream (Stdin_Pipes (1)).all'Access;
      end if;

      if Stdout_Pipes (0) /= NO_FILE then
         Result := Sys_Close (Stdout_Pipes (1));
         Proc.Output := Create_Stream (Stdout_Pipes (0)).all'Access;
      end if;

      if Stderr_Pipes (0) /= NO_FILE then
         Result := Sys_Close (Stderr_Pipes (1));
         Proc.Error := Create_Stream (Stderr_Pipes (0)).all'Access;
      end if;

   end Spawn;

   procedure Free is
     new Ada.Unchecked_Deallocation (Name => Ptr_Ptr_Array, Object => Ptr_Array);

   --  ------------------------------
   --  Append the argument to the process argument list.
   --  ------------------------------
   overriding
   procedure Append_Argument (Sys : in out System_Process;
                              Arg : in String) is
   begin
      if Sys.Argv = null then
         Sys.Argv := new Ptr_Array (0 .. 10);
      elsif Sys.Argc = Sys.Argv'Last - 1 then
         declare
            N : constant Ptr_Ptr_Array := new Ptr_Array (0 .. Sys.Argc + 32);
         begin
            N (0 .. Sys.Argc) := Sys.Argv (0 .. Sys.Argc);
            Free (Sys.Argv);
            Sys.Argv := N;
         end;
      end if;

      Sys.Argv (Sys.Argc) := Interfaces.C.Strings.New_String (Arg);
      Sys.Argc := Sys.Argc + 1;
      Sys.Argv (Sys.Argc) := Interfaces.C.Strings.Null_Ptr;
   end Append_Argument;

   --  ------------------------------
   --  Set the process input, output and error streams to redirect and use specified files.
   --  ------------------------------
   overriding
   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
   begin
      if Input'Length > 0 then
         Sys.In_File := Interfaces.C.Strings.New_String (Input);
      end if;
      if Output'Length > 0 then
         Sys.Out_File   := Interfaces.C.Strings.New_String (Output);
         Sys.Out_Append := Append_Output;
      end if;
      if Error'Length > 0 then
         Sys.Err_File   := Interfaces.C.Strings.New_String (Error);
         Sys.Err_Append := Append_Error;
      end if;
      Sys.To_Close := To_Close;
   end Set_Streams;

   --  ------------------------------
   --  Deletes the storage held by the system process.
   --  ------------------------------
   overriding
   procedure Finalize (Sys : in out System_Process) is
   begin
      if Sys.Argv /= null then
         for I in Sys.Argv'Range loop
            Interfaces.C.Strings.Free (Sys.Argv (I));
         end loop;
         Free (Sys.Argv);
      end if;
      Interfaces.C.Strings.Free (Sys.In_File);
      Interfaces.C.Strings.Free (Sys.Out_File);
      Interfaces.C.Strings.Free (Sys.Err_File);
      Interfaces.C.Strings.Free (Sys.Dir);
   end Finalize;

end Util.Processes.Os;

Fix compilation warning

Fix compilation warning


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

with Util.Serialize.Mappers.Record_Mapper;
package body Security.Controllers.Roles is

   --  ------------------------------
   --  Returns true if the user associated with the security context Context has
   --  one of the role defined in the Handler.
   --  ------------------------------
   function Has_Permission (Handler    : in Role_Controller;
                            Context    : in Security.Contexts.Security_Context'Class;
                            Permission : in Security.Permissions.Permission'Class)
                            return Boolean is
      use type Security.Principal_Access;

      P : constant Security.Principal_Access := Context.Get_User_Principal;
   begin
      if P /= null then
         for I in Handler.Roles'Range loop
--              if P.Has_Role (Handler.Roles (I)) then
               return True;
--              end if;
         end loop;
      end if;
      return False;
   end Has_Permission;

   type Config_Fields is (FIELD_NAME, FIELD_ROLE, FIELD_ROLE_PERMISSION, FIELD_ROLE_NAME);

   type Controller_Config_Access is access all Controller_Config;

   procedure Set_Member (Into  : in out Controller_Config;
                         Field : in Config_Fields;
                         Value : in Util.Beans.Objects.Object);

   --  ------------------------------
   --  Called while parsing the XML policy file when the <name>, <role> and <role-permission>
   --  XML entities are found.  Create the new permission when the complete permission definition
   --  has been parsed and save the permission in the security manager.
   --  ------------------------------
   procedure Set_Member (Into  : in out Controller_Config;
                         Field : in Config_Fields;
                         Value : in Util.Beans.Objects.Object) is
   begin
      case Field is
         when FIELD_NAME =>
            Into.Name := Value;

         when FIELD_ROLE =>
            declare
               Role : constant String := Util.Beans.Objects.To_String (Value);
            begin
               Into.Roles (Into.Count + 1) := Into.Manager.Find_Role (Role);
               Into.Count := Into.Count + 1;

            exception
               when Permissions.Invalid_Name =>
                  raise Util.Serialize.Mappers.Field_Error with "Invalid role: " & Role;
            end;

         when FIELD_ROLE_PERMISSION =>
            if Into.Count = 0 then
               raise Util.Serialize.Mappers.Field_Error with "Missing at least one role";
            end if;
            declare
               Name : constant String := Util.Beans.Objects.To_String (Into.Name);
               Perm : constant Role_Controller_Access
                 := new Role_Controller '(Count => Into.Count,
                                          Roles => Into.Roles (1 .. Into.Count));
            begin
               Into.Manager.Add_Permission (Name, Perm.all'Access);
               Into.Count := 0;
            end;

         when FIELD_ROLE_NAME =>
            declare
               Name : constant String := Util.Beans.Objects.To_String (Value);
               Role : Permissions.Role_Type;
            begin
               Into.Manager.Add_Role_Type (Name, Role);
            end;
      end case;
   end Set_Member;

   package Config_Mapper is
     new Util.Serialize.Mappers.Record_Mapper (Element_Type        => Controller_Config,
                                               Element_Type_Access => Controller_Config_Access,
                                               Fields              => Config_Fields,
                                               Set_Member          => Set_Member);

   Mapper : aliased Config_Mapper.Mapper;

   --  ------------------------------
   --  Setup the XML parser to read the role-permission description.  For example:
   --
   --  <security-role>
   --    <role-name>admin</role-name>
   --  </security-role>
   --  <role-permission>
   --     <name>create-workspace</name>
   --     <role>admin</role>
   --     <role>manager</role>
   --  </role-permission>
   --
   --  This defines a permission create-workspace that will be granted if the
   --  user has either the admin or the manager role.
   --  ------------------------------
   package body Reader_Config is
   begin
      Reader.Add_Mapping ("policy-rules", Mapper'Access);
      Reader.Add_Mapping ("module", Mapper'Access);
      Config.Manager := Manager;
      Config_Mapper.Set_Context (Reader, Config'Unchecked_Access);
   end Reader_Config;

begin
   Mapper.Add_Mapping ("role-permission", FIELD_ROLE_PERMISSION);
   Mapper.Add_Mapping ("role-permission/name", FIELD_NAME);
   Mapper.Add_Mapping ("role-permission/role", FIELD_ROLE);
   Mapper.Add_Mapping ("security-role/role-name", FIELD_ROLE_NAME);
end Security.Controllers.Roles;

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

package body Security.Controllers.Roles is

   --  ------------------------------
   --  Returns true if the user associated with the security context Context has
   --  one of the role defined in the Handler.
   --  ------------------------------
   function Has_Permission (Handler    : in Role_Controller;
                            Context    : in Security.Contexts.Security_Context'Class;
                            Permission : in Security.Permissions.Permission'Class)
                            return Boolean is
      use type Security.Principal_Access;

      P : constant Security.Principal_Access := Context.Get_User_Principal;
   begin
      if P /= null then
         for I in Handler.Roles'Range loop
--              if P.Has_Role (Handler.Roles (I)) then
               return True;
--              end if;
         end loop;
      end if;
      return False;
   end Has_Permission;

end Security.Controllers.Roles;

Remove the XML configuration reader which is now in Security.Policy.Roles