-----------------------------------------------------------------------
--  druss-commands-status -- Druss status commands
--  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 Util.Properties;
with Util.Strings;
with Druss.Gateways;
package body Druss.Commands.Status is

   --  ------------------------------
   --  Execute the wifi 'status' command to print the Wifi current status.
   --  ------------------------------
   procedure Do_Status (Command   : in Command_Type;
                        Args      : in Argument_List'Class;
                        Context   : in out Context_Type) is
      pragma Unreferenced (Command, Args);
      procedure Box_Status (Gateway : in out Druss.Gateways.Gateway_Type);

      Console : constant Druss.Commands.Consoles.Console_Access := Context.Console;
      N : Natural := 0;

      procedure Box_Status (Gateway : in out Druss.Gateways.Gateway_Type) is
      begin
         Gateway.Refresh;
         Console.Start_Row;
         Console.Print_Field (F_IP_ADDR, Gateway.Ip);
         Console.Print_Field (F_WAN_IP, Gateway.Wan.Get ("wan.ip.address", " "));
         Print_Status (Console, F_INTERNET, Gateway.Wan.Get ("wan.internet.state", " "));
         Console.Print_Field (F_VOIP, Gateway.Voip.Get ("voip.0.status", " "));
         Print_On_Off (Console, F_WIFI, Gateway.Wifi.Get ("wireless.radio.24.enable", " "));
         if not Gateway.Wifi.Exists ("wireless.radio.5.enable") then
            Console.Print_Field (F_WIFI5, "");
         else
            Print_On_Off (Console, F_WIFI5, Gateway.Wifi.Get ("wireless.radio.5.enable", " "));
         end if;
         Console.Print_Field (F_ACCESS_CONTROL, Gateway.IPtv.Get ("iptv.length", "x"));
         Console.Print_Field (F_DEVICES, Gateway.Hosts.Get ("hosts.list.length", ""));
         Print_Uptime (Console, F_UPTIME, Gateway.Device.Get ("device.uptime", ""));
         Console.End_Row;
         N := N + 1;
         Gateway.Hosts.Save_Properties ("sum-" & Util.Strings.Image (N) & ".properties");
      end Box_Status;

   begin
      Console.Start_Title;
      Console.Print_Title (F_IP_ADDR, "LAN IP", 16);
      Console.Print_Title (F_WAN_IP, "WAN IP", 16);
      Console.Print_Title (F_INTERNET, "Internet", 9);
      Console.Print_Title (F_VOIP, "VoIP", 6);
      Console.Print_Title (F_WIFI, "Wifi 2.4G", 10);
      Console.Print_Title (F_WIFI5, "Wifi 5G", 10);
      Console.Print_Title (F_ACCESS_CONTROL, "Parental", 10);
      Console.Print_Title (F_DYNDNS, "DynDNS", 10);
      Console.Print_Title (F_DEVICES, "Devices", 12);
      Console.Print_Title (F_UPTIME, "Uptime", 12);
      Console.End_Title;
      Druss.Gateways.Iterate (Context.Gateways, Gateways.ITER_ENABLE, Box_Status'Access);
   end Do_Status;

   --  ------------------------------
   --  Execute a status command to report information about the Bbox.
   --  ------------------------------
   overriding
   procedure Execute (Command   : in out Command_Type;
                      Name      : in String;
                      Args      : in Argument_List'Class;
                      Context   : in out Context_Type) is
      pragma Unreferenced (Name);
   begin
      Command.Do_Status (Args, Context);
   end Execute;

   --  ------------------------------
   --  Write the help associated with the command.
   --  ------------------------------
   overriding
   procedure Help (Command   : in Command_Type;
                   Context   : in out Context_Type) is
      pragma Unreferenced (Command);

      Console : constant Druss.Commands.Consoles.Console_Access := Context.Console;
   begin
      Console.Notice (N_HELP, "status: give information about the Bbox status");
      Console.Notice (N_HELP, "Usage: wifi {<action>} [<parameters>]");
      Console.Notice (N_HELP, "");
      Console.Notice (N_HELP, "  status [IP]...      Give information about the Bbox status");
   end Help;

end Druss.Commands.Status;

-----------------------------------------------------------------------
--  druss-commands-status -- Druss status commands
--  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.Properties;
with Util.Strings;
with Druss.Gateways;
package body Druss.Commands.Status is

   --  ------------------------------
   --  Execute the wifi 'status' command to print the Wifi current status.
   --  ------------------------------
   procedure Do_Status (Command   : in Command_Type;
                        Args      : in Argument_List'Class;
                        Context   : in out Context_Type) is
      pragma Unreferenced (Command, Args);
      procedure Box_Status (Gateway : in out Druss.Gateways.Gateway_Type);

      Console : constant Druss.Commands.Consoles.Console_Access := Context.Console;
      N : Natural := 0;

      procedure Box_Status (Gateway : in out Druss.Gateways.Gateway_Type) is
      begin
         Gateway.Refresh;
         Console.Start_Row;
         Console.Print_Field (F_IP_ADDR, Gateway.Ip);
         Console.Print_Field (F_WAN_IP, Gateway.Wan.Get ("wan.ip.address", " "));
         Print_Status (Console, F_INTERNET, Gateway.Wan.Get ("wan.internet.state", " "));
         Console.Print_Field (F_VOIP, Gateway.Voip.Get ("voip.0.status", " "));
         Print_On_Off (Console, F_WIFI, Gateway.Wifi.Get ("wireless.radio.24.enable", " "));
         if not Gateway.Wifi.Exists ("wireless.radio.5.enable") then
            Console.Print_Field (F_WIFI5, "");
         else
            Print_On_Off (Console, F_WIFI5, Gateway.Wifi.Get ("wireless.radio.5.enable", " "));
         end if;
         Console.Print_Field (F_ACCESS_CONTROL, Gateway.IPtv.Get ("iptv.length", "x"));
         Console.Print_Field (F_DEVICES, Gateway.Hosts.Get ("hosts.list.length", ""));
         Print_Uptime (Console, F_UPTIME, Gateway.Device.Get ("device.uptime", ""));
         Console.End_Row;
         N := N + 1;
         Gateway.Hosts.Save_Properties ("sum-" & Util.Strings.Image (N) & ".properties");
      end Box_Status;

   begin
      Console.Start_Title;
      Console.Print_Title (F_IP_ADDR, "LAN IP", 16);
      Console.Print_Title (F_WAN_IP, "WAN IP", 16);
      Console.Print_Title (F_INTERNET, "Internet", 9);
      Console.Print_Title (F_VOIP, "VoIP", 6);
      Console.Print_Title (F_WIFI, "Wifi 2.4G", 10);
      Console.Print_Title (F_WIFI5, "Wifi 5G", 10);
      Console.Print_Title (F_ACCESS_CONTROL, "Parental", 10);
      Console.Print_Title (F_DYNDNS, "DynDNS", 10);
      Console.Print_Title (F_DEVICES, "Devices", 12);
      Console.Print_Title (F_UPTIME, "Uptime", 12);
      Console.End_Title;
      Druss.Gateways.Iterate (Context.Gateways, Gateways.ITER_ENABLE, Box_Status'Access);
   end Do_Status;

   --  ------------------------------
   --  Execute a status command to report information about the Bbox.
   --  ------------------------------
   overriding
   procedure Execute (Command   : in out Command_Type;
                      Name      : in String;
                      Args      : in Argument_List'Class;
                      Context   : in out Context_Type) is
      pragma Unreferenced (Name);
   begin
      Command.Do_Status (Args, Context);
   end Execute;

   --  ------------------------------
   --  Write the help associated with the command.
   --  ------------------------------
   overriding
   procedure Help (Command   : in out Command_Type;
                   Context   : in out Context_Type) is
      pragma Unreferenced (Command);

      Console : constant Druss.Commands.Consoles.Console_Access := Context.Console;
   begin
      Console.Notice (N_HELP, "status: give information about the Bbox status");
      Console.Notice (N_HELP, "Usage: wifi {<action>} [<parameters>]");
      Console.Notice (N_HELP, "");
      Console.Notice (N_HELP, "  status [IP]...      Give information about the Bbox status");
   end Help;

end Druss.Commands.Status;

Change Help command to accept in out command


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

with GNAT.Command_Line;

with ASF.Applications.Main;
with ASF.Requests.Mockup;
with ASF.Responses.Mockup;
with ASF.Contexts.Faces;

with EL.Objects;
with EL.Contexts;
with EL.Contexts.Default;
with EL.Variables;
with EL.Variables.Default;
with ASF.Streams;
--  This example reads an XHTML file and renders the result.
procedure Render is

   use GNAT.Command_Line;
   use Ada.Strings.Fixed;

   use ASF;
   use ASF.Contexts.Faces;

   use EL.Contexts.Default;
   use EL.Variables;
   use EL.Variables.Default;
   use EL.Contexts;
   use EL.Objects;

   App      : Applications.Main.Application;
   Conf      : Applications.Config;
begin
   loop
      case Getopt ("D:") is
         when 'D' =>
            declare
               Value : constant String := Parameter;
               Pos   : constant Natural := Index (Value, "=");
            begin
--                 if Pos > 0 then
--                    Variables.Set_Variable (Value (1 .. Pos - 1),
--                                            To_Object (Value (Pos + 1 .. Value'Last)));
--                 else
--                    Variables.Set_Variable (Value, To_Object(True));
--                 end if;
               null;
            end;

         when others =>
            exit;
      end case;
   end loop;

   Conf.Set ("view.ignore_white_spaces", "false");
   Conf.Set ("view.escape_unknown_tags", "false");
   Conf.Set ("view.ignore_empty_lines", "true");
   declare
      View_Name : constant String := Get_Argument;
      Req       : ASF.Requests.Mockup.Request;
      Reply     : ASF.Responses.Mockup.Response;
      Content   : Ada.Strings.Unbounded.Unbounded_String;
   begin
      App.Initialize (Conf);

      App.Dispatch (Page     => View_Name,
                    Request  => Req,
                    Response => Reply);

      Reply.Read_Content (Content);
      Ada.Text_IO.Put_Line (Ada.Strings.Unbounded.To_String (Content));

   exception
      when Ada.IO_Exceptions.Name_Error =>
         Ada.Text_IO.Put_Line ("Cannot read file '" & View_Name & "'");
   end;
end Render;

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

with GNAT.Command_Line;

with ASF.Applications.Main;
with ASF.Requests.Mockup;
with ASF.Responses.Mockup;

with EL.Objects;
--  This example reads an XHTML file and renders the result.
procedure Render is

   use GNAT.Command_Line;
   use Ada.Strings.Fixed;

   use ASF;

   use EL.Objects;

   Factory  : ASF.Applications.Main.Application_Factory;
   App      : Applications.Main.Application;
   Conf     : Applications.Config;
begin
   Conf.Set ("view.ignore_white_spaces", "false");
   Conf.Set ("view.escape_unknown_tags", "false");
   Conf.Set ("view.ignore_empty_lines", "true");

   App.Initialize (Conf, Factory);
   loop
      case Getopt ("D:") is
         when 'D' =>
            declare
               Value : constant String := Parameter;
               Pos   : constant Natural := Index (Value, "=");
            begin
               if Pos > 0 then
                  App.Set_Global (Name  => Value (1 .. Pos - 1),
                                  Value => To_Object (Value (Pos + 1 .. Value'Last)));
               else
                  App.Set_Global (Name  => Value (1 .. Pos - 1),
                                  Value => To_Object(True));
               end if;
            end;

         when others =>
            exit;
      end case;
   end loop;

   declare
      View_Name : constant String := Get_Argument;
      Req       : ASF.Requests.Mockup.Request;
      Reply     : ASF.Responses.Mockup.Response;
      Content   : Ada.Strings.Unbounded.Unbounded_String;
   begin

      App.Dispatch (Page     => View_Name,
                    Request  => Req,
                    Response => Reply);

      Reply.Read_Content (Content);
      Ada.Text_IO.Put_Line (Ada.Strings.Unbounded.To_String (Content));

   exception
      when Ada.IO_Exceptions.Name_Error =>
         Ada.Text_IO.Put_Line ("Cannot read file '" & View_Name & "'");
   end;
end Render;

Update the render example

Update the render example


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

package body Babel.Files.Maps is

   --  ------------------------------
   --  Find the file with the given name in the file map.
   --  ------------------------------
   function Find (From : in File_Map;
                  Name : in String) return File_Cursor is
   begin
      return From.Find (Key => Name'Unrestricted_Access);
   end Find;

   --  ------------------------------
   --  Add the file with the given name in the container.
   --  ------------------------------
   procedure Add_File (Into    : in out Differential_Container;
                       Element : in File_Type) is
      use type ADO.Identifier;
   begin
      if Element.Id = ADO.NO_IDENTIFIER then
         Into.Known_Files.Insert (Element.Name'Unrestricted_Access, Element);
      end if;
   end Add_File;

   --  ------------------------------
   --  Add the directory with the given name in the container.
   --  ------------------------------
   procedure Add_Directory (Into    : in out Differential_Container;
                            Element : in Directory_Type) is
      use type ADO.Identifier;
   begin
      if Element.Id = ADO.NO_IDENTIFIER then
         Into.Known_Dirs.Insert (Element.Name'Unrestricted_Access, Element);
      end if;
   end Add_Directory;

   --  ------------------------------
   --  Create a new file instance with the given name in the container.
   --  ------------------------------
   function Create (Into : in Differential_Container;
                    Name : in String) return File_Type is
   begin
      return Allocate (Name => Name,
                       Dir  => Into.Current);
   end Create;

   --  ------------------------------
   --  Create a new directory instance with the given name in the container.
   --  ------------------------------
   function Create (Into : in Differential_Container;
                    Name : in String) return Directory_Type is
   begin
      return Allocate (Name => Name,
                       Dir  => Into.Current);
   end Create;

   --  ------------------------------
   --  Find the file with the given name in this file container.
   --  Returns NO_FILE if the file was not found.
   --  ------------------------------
   function Find (From : in Differential_Container;
                  Name : in String) return File_Type is
   begin
      return Find (From.Known_Files, Name);
   end Find;

   --  ------------------------------
   --  Find the directory with the given name in this file container.
   --  Returns NO_DIRECTORY if the directory was not found.
   --  ------------------------------
   function Find (From : in Differential_Container;
                  Name : in String) return Directory_Type is
   begin
      return Find (From.Known_Dirs, Name);
   end Find;

   --  ------------------------------
   --  Set the directory object associated with the container.
   --  ------------------------------
   overriding
   procedure Set_Directory (Into      : in out Differential_Container;
                            Directory : in Directory_Type) is
   begin
      Default_Container (Into).Set_Directory (Directory);
      Into.Known_Files.Clear;
      Into.Known_Dirs.Clear;
   end Set_Directory;

   --  ------------------------------
   --  Prepare the differential container by setting up the known files and known
   --  directories.  The <tt>Update</tt> procedure is called to give access to the
   --  maps that can be updated.
   --  ------------------------------
   procedure Prepare (Container : in out Differential_Container;
                      Update    : access procedure (Files : in out File_Map;
                                                    Dirs  : in out Directory_Map)) is
   begin
      Update (Container.Known_Files, Container.Known_Dirs);
   end Prepare;

end Babel.Files.Maps;

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

package body Babel.Files.Maps is

   --  ------------------------------
   --  Find the file with the given name in the file map.
   --  ------------------------------
   function Find (From : in File_Map;
                  Name : in String) return File_Cursor is
   begin
      return From.Find (Key => Name'Unrestricted_Access);
   end Find;

   --  ------------------------------
   --  Find the file with the given name in the file map.
   --  ------------------------------
   function Find (From : in File_Map;
                  Name : in String) return File_Type is
      Pos : constant File_Cursor := From.Find (Key => Name'Unrestricted_Access);
   begin
      if File_Maps.Has_Element (Pos) then
         return File_Maps.Element (Pos);
      else
         return NO_FILE;
      end if;
   end Find;

   --  ------------------------------
   --  Add the file with the given name in the container.
   --  ------------------------------
   procedure Add_File (Into    : in out Differential_Container;
                       Element : in File_Type) is
      use type ADO.Identifier;
   begin
      if Element.Id = ADO.NO_IDENTIFIER then
         Into.Known_Files.Insert (Element.Name'Unrestricted_Access, Element);
      end if;
   end Add_File;

   --  ------------------------------
   --  Add the directory with the given name in the container.
   --  ------------------------------
   procedure Add_Directory (Into    : in out Differential_Container;
                            Element : in Directory_Type) is
      use type ADO.Identifier;
   begin
      if Element.Id = ADO.NO_IDENTIFIER then
         Into.Known_Dirs.Insert (Element.Name'Unrestricted_Access, Element);
      end if;
   end Add_Directory;

   --  ------------------------------
   --  Create a new file instance with the given name in the container.
   --  ------------------------------
   function Create (Into : in Differential_Container;
                    Name : in String) return File_Type is
   begin
      return Allocate (Name => Name,
                       Dir  => Into.Current);
   end Create;

   --  ------------------------------
   --  Create a new directory instance with the given name in the container.
   --  ------------------------------
   function Create (Into : in Differential_Container;
                    Name : in String) return Directory_Type is
   begin
      return Allocate (Name => Name,
                       Dir  => Into.Current);
   end Create;

   --  ------------------------------
   --  Find the file with the given name in this file container.
   --  Returns NO_FILE if the file was not found.
   --  ------------------------------
   function Find (From : in Differential_Container;
                  Name : in String) return File_Type is
   begin
      return Find (From.Known_Files, Name);
   end Find;

   --  ------------------------------
   --  Find the directory with the given name in this file container.
   --  Returns NO_DIRECTORY if the directory was not found.
   --  ------------------------------
   function Find (From : in Differential_Container;
                  Name : in String) return Directory_Type is
   begin
      return Find (From.Known_Dirs, Name);
   end Find;

   --  ------------------------------
   --  Set the directory object associated with the container.
   --  ------------------------------
   overriding
   procedure Set_Directory (Into      : in out Differential_Container;
                            Directory : in Directory_Type) is
   begin
      Default_Container (Into).Set_Directory (Directory);
      Into.Known_Files.Clear;
      Into.Known_Dirs.Clear;
   end Set_Directory;

   --  ------------------------------
   --  Prepare the differential container by setting up the known files and known
   --  directories.  The <tt>Update</tt> procedure is called to give access to the
   --  maps that can be updated.
   --  ------------------------------
   procedure Prepare (Container : in out Differential_Container;
                      Update    : access procedure (Files : in out File_Map;
                                                    Dirs  : in out Directory_Map)) is
   begin
      Update (Container.Known_Files, Container.Known_Dirs);
   end Prepare;

end Babel.Files.Maps;

Implement the Find operation to retrieve a File_Type instance


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

   --  ------------------------------
   --  Read a complete file into a string.
   --  The Max_Size parameter indicates the maximum size that is read.
   --  ------------------------------
   procedure Read_File (Path     : in String;
                        Into     : out Unbounded_String;
                        Max_Size : in Natural := 0) is
      use Ada.Streams;
      use Ada.Streams.Stream_IO;

      F      : File_Type;
      Buffer : Stream_Element_Array (1 .. 10_000);
      Pos    : Positive_Count := 1;
      Last   : Stream_Element_Offset;
      Space  : Natural;
   begin
      if Max_Size = 0 then
         Space := Natural'Last;
      else
         Space := Max_Size;
      end if;
      Open (Name => Path, File => F, Mode => In_File);
      loop
         Read (File => F, Item => Buffer, From => Pos, Last => Last);
         if Natural (Last) > Space then
            Last := Stream_Element_Offset (Space);
         end if;
         for I in 1 .. Last loop
            Append (Into, Character'Val (Buffer (I)));
         end loop;
         exit when Last < Buffer'Length;
         Pos := Pos + Positive_Count (Last);
      end loop;
      Close (F);

   exception
      when others =>
         if Is_Open (F) then
            Close (F);
         end if;
         raise;
   end Read_File;

   --  ------------------------------
   --  Read the file with the given path, one line at a time and execute the Process
   --  procedure with each line as argument.
   --  ------------------------------
   procedure Read_File (Path     : in String;
                        Process  : not null access procedure (Line : in String)) is
      File : Ada.Text_IO.File_Type;
   begin
      Ada.Text_IO.Open (File => File,
                        Mode => Ada.Text_IO.In_File,
                        Name => Path);
      while not Ada.Text_IO.End_Of_File (File) loop
         Process (Ada.Text_IO.Get_Line (File));
      end loop;
      Ada.Text_IO.Close (File);
   end Read_File;

   --  ------------------------------
   --  Read the file with the given path, one line at a time and append each line to
   --  the Into vector.
   --  ------------------------------
   procedure Read_File (Path  : in String;
                        Into  : in out Util.Strings.Vectors.Vector) is
      procedure Append (Line : in String);
      procedure Append (Line : in String) is
      begin
         Into.Append (Line);
      end Append;
   begin
      Read_File (Path, Append'Access);
   end Read_File;

   --  ------------------------------
   --  Save the string into a file creating the file if necessary
   --  ------------------------------
   procedure Write_File (Path    : in String;
                         Content : in String) is
      use Ada.Streams;
      use Ada.Streams.Stream_IO;
      use Ada.Directories;

      F : File_Type;
      Buffer : Stream_Element_Array (Stream_Element_Offset (Content'First)
                                     .. Stream_Element_Offset (Content'Last));

      Dir : constant String := Containing_Directory (Path);
   begin
      if not Exists (Dir) then
         Create_Path (Dir);
      end if;
      Create (File => F, Name => Path);
      for I in Content'Range loop
         Buffer (Stream_Element_Offset (I))
           := Stream_Element (Character'Pos (Content (I)));
      end loop;
      Write (F, Buffer);
      Close (F);

   exception
      when others =>
         if Is_Open (F) then
            Close (F);
         end if;
         raise;
   end Write_File;

   --  ------------------------------
   --  Save the string into a file creating the file if necessary
   --  ------------------------------
   procedure Write_File (Path    : in String;
                         Content : in Unbounded_String) is
   begin
      Write_File (Path, Ada.Strings.Unbounded.To_String (Content));
   end Write_File;

   --  ------------------------------
   --  Iterate over the search directories defined in Paths and execute
   --  Process with each directory until it returns True in Done
   --  or the last search directory is found.  Each search directory
   --  is separated by ';' (yes, even on Unix).  When Going is set to Backward, the
   --  directories are searched in reverse order.
   --  ------------------------------
   procedure Iterate_Path (Path     : in String;
                           Process  : not null access procedure (Dir  : in String;
                                                                 Done : out Boolean);
                           Going    : in Direction := Ada.Strings.Forward) is
   begin
      Util.Strings.Tokenizers.Iterate_Tokens (Content => Path,
                                              Pattern => ";",
                                              Process => Process,
                                              Going   => Going);
   end Iterate_Path;

   --  ------------------------------
   --  Find the file in one of the search directories.  Each search directory
   --  is separated by ';' (yes, even on Unix).
   --  Returns the path to be used for reading the file.
   --  ------------------------------
   function Find_File_Path (Name  : String;
                            Paths : String) return String is
      use Ada.Strings.Fixed;

      Sep_Pos : Natural;
      Pos     : Positive := Paths'First;
      Last    : constant Natural := Paths'Last;

   begin
      while Pos <= Last loop
         Sep_Pos := Index (Paths, ";", Pos);
         if Sep_Pos = 0 then
            Sep_Pos := Last;
         else
            Sep_Pos := Sep_Pos - 1;
         end if;
         declare
         use Ada.Directories;

            Path : constant String := Util.Files.Compose (Paths (Pos .. Sep_Pos), Name);
         begin
            if Exists (Path) and then Kind (Path) = Ordinary_File then
               return Path;
            end if;
         exception
            when Name_Error =>
               null;
         end;
         Pos := Sep_Pos + 2;
      end loop;
      return Name;
   end Find_File_Path;

   --  ------------------------------
   --  Iterate over the search directories defined in Path and search
   --  for files matching the pattern defined by Pattern.  For each file,
   --  execute Process with the file basename and the full file path.
   --  Stop iterating when the Process procedure returns True.
   --  Each search directory is separated by ';'.  When Going is set to Backward, the
   --  directories are searched in reverse order.
   --  ------------------------------
   procedure Iterate_Files_Path (Pattern  : in String;
                                 Path     : in String;
                                 Process  : not null access procedure (Name : in String;
                                                                       File : in String;
                                                                       Done : out Boolean);
                                 Going    : in Direction := Ada.Strings.Forward) is

      procedure Find_Files (Dir  : in String;
                            Done : out Boolean);

      --  ------------------------------
      --  Find the files matching the pattern in Dir.
      --  ------------------------------
      procedure Find_Files (Dir  : in String;
                            Done : out Boolean) is
         use Ada.Directories;

         Filter  : constant Filter_Type := (Ordinary_File => True, others => False);
         Ent     : Directory_Entry_Type;
         Search  : Search_Type;
      begin
         Done := False;
         Start_Search (Search, Directory => Dir,
                       Pattern => Pattern, Filter => Filter);
         while More_Entries (Search) loop
            Get_Next_Entry (Search, Ent);
            declare
               Name      : constant String := Simple_Name (Ent);
               File_Path : constant String := Full_Name (Ent);
            begin
               Process (Name, File_Path, Done);
               exit when Done;
            end;
         end loop;
      end Find_Files;

   begin
      Iterate_Path (Path => Path, Process => Find_Files'Access, Going => Going);
   end Iterate_Files_Path;

   --  ------------------------------
   --  Find the files which match the pattern in the directories specified in the
   --  search path Path.  Each search directory is separated by ';'.
   --  File names are added to the string set in Into.
   --  ------------------------------
   procedure Find_Files_Path (Pattern : in String;
                              Path    : in String;
                              Into    : in out Util.Strings.Maps.Map) is

      procedure Add_File (Name : in String;
                          File_Path : in String;
                          Done : out Boolean);

      --  ------------------------------
      --  Find the files matching the pattern in Dir.
      --  ------------------------------
      procedure Add_File (Name : in String;
                          File_Path : in String;
                          Done      : out Boolean) is
      begin
         if not Into.Contains (Name) then
            Into.Insert (Name, File_Path);
         end if;
         Done := False;
      end Add_File;

   begin
      Iterate_Files_Path (Pattern => Pattern, Path => Path, Process => Add_File'Access);
   end Find_Files_Path;

   --  ------------------------------
   --  Compose an existing path by adding the specified name to each path component
   --  and return a new paths having only existing directories.  Each directory is
   --  separated by ';'.
   --  If the composed path exists, it is added to the result path.
   --  Example:
   --    paths = 'web;regtests'  name = 'info'
   --    result = 'web/info;regtests/info'
   --  Returns the composed path.
   --  ------------------------------
   function Compose_Path (Paths : in String;
                          Name  : in String) return String is

      procedure Compose (Dir : in String;
                         Done : out Boolean);

      Result  : Unbounded_String;

      --  ------------------------------
      --  Build the new path by checking if Name exists in Dir
      --  and appending the new path in the Result.
      --  ------------------------------
      procedure Compose (Dir : in String;
                         Done : out Boolean) is
         use Ada.Directories;

         Path : constant String := Util.Files.Compose (Dir, Name);
      begin
         Done := False;
         if Exists (Path) and then Kind (Path) = Directory then
            if Length (Result) > 0 then
               Append (Result, ';');
            end if;
            Append (Result, Path);
         end if;
      exception
         when Name_Error =>
            null;
      end Compose;

   begin
      Iterate_Path (Path => Paths, Process => Compose'Access);
      return To_String (Result);
   end Compose_Path;

   --  ------------------------------
   --  Returns the name of the external file with the specified directory
   --  and the name.  Unlike the Ada.Directories.Compose, the name can represent
   --  a relative path and thus include directory separators.
   --  ------------------------------
   function Compose (Directory : in String;
                     Name      : in String) return String is
   begin
      if Name'Length = 0 then
         return Directory;
      elsif Directory'Length = 0 then
         return Name;
      elsif Directory = "." or else Directory = "./" then
         if Name (Name'First) = '/' then
            return Compose (Directory, Name (Name'First + 1 .. Name'Last));
         else
            return Name;
         end if;
      elsif Directory (Directory'Last) = '/' and then Name (Name'First) = '/' then
         return Directory & Name (Name'First + 1 .. Name'Last);
      elsif Directory (Directory'Last) = '/' or else Name (Name'First) = '/' then
         return Directory & Name;
      else
         return Directory & "/" & Name;
      end if;
   end Compose;

   --  ------------------------------
   --  Returns a relative path whose origin is defined by From and which refers
   --  to the absolute path referenced by To.  Both From and To are
   --  assumed to be absolute pathes.  Returns the absolute path To if the relative
   --  path could not be found.  Both paths must have at least one root component in common.
   --  ------------------------------
   function Get_Relative_Path (From : in String;
                               To   : in String) return String is
      Result : Unbounded_String;
      Last   : Natural := 0;
   begin
      for I in From'Range loop
         if I > To'Last or else From (I) /= To (I) then
            --  Nothing in common, return the absolute path To.
            if Last <= From'First + 1 then
               return To;
            end if;

            for J in Last .. From'Last - 1 loop
               if From (J) = '/' or From (J) = '\' then
                  Append (Result, "../");
               end if;
            end loop;
            if Last <= To'Last and From (I) /= '/' and From (I) /= '\' then
               Append (Result, "../");
               Append (Result, To (Last .. To'Last));
            end if;
            return To_String (Result);

         elsif I < From'Last and then (From (I) = '/' or From (I) = '\') then
            Last := I + 1;

         end if;
      end loop;
      if To'Last = From'Last or (To'Last = From'Last + 1
                                 and (To (To'Last) = '/' or To (To'Last) = '\'))
      then
         return ".";
      elsif Last = 0 then
         return To;
      elsif To (From'Last + 1) = '/' or To (From'Last + 1) = '\' then
         return To (From'Last + 2 .. To'Last);
      else
         return To (Last .. To'Last);
      end if;
   end Get_Relative_Path;

end Util.Files;

Fix style compilation warning

Fix style compilation warning


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

with Util.Test_Caller;
with Util.Beans.Basic;
with Util.Beans.Objects;

with ADO;
with ADO.Objects;

with Security.Contexts;

with ASF.Contexts.Faces;
with ASF.Contexts.Faces.Mockup;

with AWA.Permissions;
with AWA.Services.Contexts;
with AWA.Questions.Modules;
with AWA.Questions.Beans;
with AWA.Votes.Beans;
with AWA.Tests.Helpers.Users;
package body AWA.Questions.Services.Tests is

   use Util.Tests;
   use ADO;

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test AWA.Questions.Services.Save_Question",
                       Test_Create_Question'Access);
      Caller.Add_Test (Suite, "Test AWA.Questions.Queries question-list",
                       Test_List_Questions'Access);
      Caller.Add_Test (Suite, "Test AWA.Questions.Beans questionVote bean",
                       Test_Question_Vote'Access);
      Caller.Add_Test (Suite, "Test AWA.Questions.Beans questionVote bean (anonymous user)",
                       Test_Question_Vote'Access);
   end Add_Tests;

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

      T.Manager := AWA.Questions.Modules.Get_Question_Manager;
      T.Assert (T.Manager /= null, "There is no question manager");

      Q.Set_Title ("How can I append strings in Ada?");
      Q.Set_Description ("I have two strings that I want to concatenate.  + does not work.");
      T.Manager.Save_Question (Q);
      T.Assert (Q.Is_Inserted, "The new question was not inserted");

      Q.Set_Description ("I have two strings that I want to concatenate.  + does not work. "
                        & "I also tried '.' without success.  What should I do?");
      T.Manager.Save_Question (Q);

      Q.Set_Description ("I have two strings that I want to concatenate.  + does not work. "
                         & "I also tried '.' without success.  What should I do? "
                         & "This is a stupid question for someone who reads this file. "
                         & "But I need some long text for the unit test.");
      T.Manager.Save_Question (Q);
   end Test_Create_Question;

   --  ------------------------------
   --  Test list of questions.
   --  ------------------------------
   procedure Test_List_Questions (T : in out Test) is
      use AWA.Questions.Models;
      use type Util.Beans.Basic.Readonly_Bean_Access;

      Sec_Ctx   : Security.Contexts.Security_Context;
      Context   : AWA.Services.Contexts.Service_Context;
      Module    : AWA.Questions.Modules.Question_Module_Access;
      List      : Util.Beans.Basic.Readonly_Bean_Access;
      Bean      : Util.Beans.Objects.Object;
      Count     : Natural;
   begin
      AWA.Tests.Helpers.Users.Anonymous (Context, Sec_Ctx);
      Module := AWA.Questions.Modules.Get_Question_Module;
      List := AWA.Questions.Beans.Create_Question_List_Bean (Module);
      T.Assert (List /= null, "The Create_Question_List_Bean returned null");

      Bean := Util.Beans.Objects.To_Object (List);
      T.Assert (not Util.Beans.Objects.Is_Null (Bean), "The list bean should not be null");
      Count := Questions.Models.Question_Info_List_Bean'Class (List.all).Get_Count;

      T.Assert (Count > 0, "The list of question is empty");
   end Test_List_Questions;

   --  ------------------------------
   --  Do a vote on a question through the question vote bean.
   --  ------------------------------
   procedure Do_Vote (T : in out Test) is
      use type Util.Beans.Basic.Readonly_Bean_Access;

      Context : ASF.Contexts.Faces.Mockup.Mockup_Faces_Context;
      Outcome : Ada.Strings.Unbounded.Unbounded_String;
      Bean    : Util.Beans.Basic.Readonly_Bean_Access;
      Vote    : AWA.Votes.Beans.Vote_Bean_Access;
   begin
      Bean := Context.Get_Bean ("questionVote");
      T.Assert (Bean /= null, "The questionVote bean was not created");

      T.Assert (Bean.all in AWA.Votes.Beans.Vote_Bean'Class,
                "The questionVote is not a Vote_Bean");

      Vote := AWA.Votes.Beans.Vote_Bean (Bean.all)'Access;
      Vote.Rating    := 1;
      Vote.Entity_Id := 1;
      Vote.Vote_Up (Outcome);
   end Do_Vote;

   --  ------------------------------
   --  Test anonymous user voting for a question.
   --  ------------------------------
   procedure Test_Question_Vote_Anonymous (T : in out Test) is
      Sec_Ctx : Security.Contexts.Security_Context;
      Context : AWA.Services.Contexts.Service_Context;
   begin
      AWA.Tests.Helpers.Users.Anonymous (Context, Sec_Ctx);

      Do_Vote (T);
      T.Fail ("Anonymous users should not be allowed to vote");

   exception
      when AWA.Permissions.NO_PERMISSION =>
         null;
   end Test_Question_Vote_Anonymous;

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

      Do_Vote (T);
   end Test_Question_Vote;

end AWA.Questions.Services.Tests;

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

with Util.Test_Caller;
with Util.Beans.Basic;
with Util.Beans.Objects;

with ADO;
with ADO.Objects;

with Security.Contexts;

with ASF.Contexts.Faces;
with ASF.Contexts.Faces.Mockup;

with AWA.Permissions;
with AWA.Services.Contexts;
with AWA.Questions.Modules;
with AWA.Questions.Beans;
with AWA.Votes.Beans;
with AWA.Tests.Helpers.Users;
package body AWA.Questions.Services.Tests is

   use Util.Tests;
   use ADO;

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test AWA.Questions.Services.Save_Question",
                       Test_Create_Question'Access);
      Caller.Add_Test (Suite, "Test AWA.Questions.Queries question-list",
                       Test_List_Questions'Access);
      Caller.Add_Test (Suite, "Test AWA.Questions.Beans questionVote bean",
                       Test_Question_Vote'Access);
      Caller.Add_Test (Suite, "Test AWA.Questions.Beans questionVote bean (anonymous user)",
                       Test_Question_Vote'Access);
   end Add_Tests;

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

      T.Manager := AWA.Questions.Modules.Get_Question_Manager;
      T.Assert (T.Manager /= null, "There is no question manager");

      Q.Set_Title ("How can I append strings in Ada?");
      Q.Set_Description ("I have two strings that I want to concatenate.  + does not work.");
      T.Manager.Save_Question (Q);
      T.Assert (Q.Is_Inserted, "The new question was not inserted");

      Q.Set_Description ("I have two strings that I want to concatenate.  + does not work. "
                        & "I also tried '.' without success.  What should I do?");
      T.Manager.Save_Question (Q);

      Q.Set_Description ("I have two strings that I want to concatenate.  + does not work. "
                         & "I also tried '.' without success.  What should I do? "
                         & "This is a stupid question for someone who reads this file. "
                         & "But I need some long text for the unit test.");
      T.Manager.Save_Question (Q);
   end Test_Create_Question;

   --  ------------------------------
   --  Test list of questions.
   --  ------------------------------
   procedure Test_List_Questions (T : in out Test) is
      use AWA.Questions.Models;
      use type Util.Beans.Basic.Readonly_Bean_Access;

      Sec_Ctx   : Security.Contexts.Security_Context;
      Context   : AWA.Services.Contexts.Service_Context;
      Module    : AWA.Questions.Modules.Question_Module_Access;
      List      : Util.Beans.Basic.Readonly_Bean_Access;
      Bean      : Util.Beans.Objects.Object;
      Count     : Natural;
   begin
      AWA.Tests.Helpers.Users.Anonymous (Context, Sec_Ctx);
      Module := AWA.Questions.Modules.Get_Question_Module;
      List := AWA.Questions.Beans.Create_Question_List_Bean (Module);
      T.Assert (List /= null, "The Create_Question_List_Bean returned null");

      Bean := Util.Beans.Objects.To_Object (List);
      T.Assert (not Util.Beans.Objects.Is_Null (Bean), "The list bean should not be null");
      Count := Questions.Models.Question_Info_List_Bean'Class (List.all).Get_Count;

      T.Assert (Count > 0, "The list of question is empty");
   end Test_List_Questions;

   --  ------------------------------
   --  Do a vote on a question through the question vote bean.
   --  ------------------------------
   procedure Do_Vote (T : in out Test) is
      use type Util.Beans.Basic.Readonly_Bean_Access;

      Context : ASF.Contexts.Faces.Mockup.Mockup_Faces_Context;
      Outcome : Ada.Strings.Unbounded.Unbounded_String;
      Bean    : Util.Beans.Basic.Readonly_Bean_Access;
      Vote    : AWA.Votes.Beans.Vote_Bean_Access;
   begin
      Context.Set_Parameter ("id", "1");
      Bean := Context.Get_Bean ("questionVote");
      T.Assert (Bean /= null, "The questionVote bean was not created");

      T.Assert (Bean.all in AWA.Votes.Beans.Vote_Bean'Class,
                "The questionVote is not a Vote_Bean");

      Vote := AWA.Votes.Beans.Vote_Bean (Bean.all)'Access;
      Vote.Rating    := 1;
      Vote.Entity_Id := 1;
      Vote.Vote_Up (Outcome);
   end Do_Vote;

   --  ------------------------------
   --  Test anonymous user voting for a question.
   --  ------------------------------
   procedure Test_Question_Vote_Anonymous (T : in out Test) is
      Sec_Ctx : Security.Contexts.Security_Context;
      Context : AWA.Services.Contexts.Service_Context;
   begin
      AWA.Tests.Helpers.Users.Anonymous (Context, Sec_Ctx);

      Do_Vote (T);
      T.Fail ("Anonymous users should not be allowed to vote");

   exception
      when AWA.Permissions.NO_PERMISSION =>
         null;
   end Test_Question_Vote_Anonymous;

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

      Do_Vote (T);
   end Test_Question_Vote;

end AWA.Questions.Services.Tests;

Add the request parameter to simulate the ajax vote action


with GNAT.IO;  use GNAT.IO;
with Babel;
with Babel.Files;
with Ada.Directories;
with Ada.Strings.Unbounded;
with Util.Encoders;
with Util.Encoders.Base16;
with Babel.Filters;
with Babel.Files.Buffers;
with Babel.Stores.Local;
with Babel.Strategies.Default;
with Babel.Strategies.Workers;
procedure babel_main is

   use Ada.Strings.Unbounded;

   Dir         : Babel.Files.Directory_Type;
   Hex_Encoder : Util.Encoders.Base16.Encoder;
   Exclude     : aliased Babel.Filters.Exclude_Directory_Filter_Type;
   Local       : aliased Babel.Stores.Local.Local_Store_Type;
   Backup      : aliased Babel.Strategies.Default.Default_Strategy_Type;
   Buffers     : aliased Babel.Files.Buffers.Buffer_Pools.Pool;
   Store       : aliased Babel.Stores.Local.Local_Store_Type;
--
--     procedure Print_Sha (Path : in String;
--                          File : in out Babel.Files.File) is
--        Sha : constant String := Hex_Encoder.Transform (File.SHA1);
--     begin
--        Put_Line (Path & "/" & To_String (File.Name) & " => " & Sha);
--     end Print_Sha;

   procedure Do_Backup (Count : in Positive) is
      Workers : Babel.Strategies.Workers.Worker_Type (Count);
   begin
      Babel.Strategies.Workers.Start (Workers, Backup'Unchecked_Access);
      Backup.Scan (".");
   end Do_Backup;

begin
   Exclude.Add_Exclude (".svn");
   Exclude.Add_Exclude ("obj");
   Babel.Files.Buffers.Create_Pool (Into => Buffers, Count => 10, Size => 1_000_000);
   Store.Set_Root_Directory ("/tmp/babel-store");
   Local.Set_Root_Directory (".");
   Backup.Set_Filters (Exclude'Unchecked_Access);
   Backup.Set_Stores (Read => Local'Unchecked_Access, Write => Store'Unchecked_Access);
   Backup.Set_Buffers (Buffers'Unchecked_Access);

   Put_Line ("Size: " & Natural'Image (Ada.Directories.File_Size'Size));
   Do_Backup (2);
--     Bkp.Files.Scan (".", Dir);
--     Bkp.Files.Iterate_Files (".", Dir, 10, Print_Sha'Access);
--     Put_Line ("Total size: " & Ada.Directories.File_Size'Image (Dir.Tot_Size));
--     Put_Line ("File count: " & Natural'Image (Dir.Tot_Files));
--     Put_Line ("Dir count:  " & Natural'Image (Dir.Tot_Dirs));
end babel_main;

with GNAT.IO;  use GNAT.IO;
with Babel;
with Babel.Files;
with Ada.Directories;
with Ada.Strings.Unbounded;
with Util.Encoders;
with Util.Encoders.Base16;
with Babel.Filters;
with Babel.Files.Buffers;
with Babel.Files.Queues;
with Babel.Stores.Local;
with Babel.Strategies.Default;
with Babel.Strategies.Workers;
procedure babel_main is

   use Ada.Strings.Unbounded;

   Dir         : Babel.Files.Directory_Type;
   Hex_Encoder : Util.Encoders.Base16.Encoder;
   Exclude     : aliased Babel.Filters.Exclude_Directory_Filter_Type;
   Local       : aliased Babel.Stores.Local.Local_Store_Type;
   Backup      : aliased Babel.Strategies.Default.Default_Strategy_Type;
   Buffers     : aliased Babel.Files.Buffers.Buffer_Pools.Pool;
   Store       : aliased Babel.Stores.Local.Local_Store_Type;
--
--     procedure Print_Sha (Path : in String;
--                          File : in out Babel.Files.File) is
--        Sha : constant String := Hex_Encoder.Transform (File.SHA1);
--     begin
--        Put_Line (Path & "/" & To_String (File.Name) & " => " & Sha);
--     end Print_Sha;

   procedure Do_Backup (Count : in Positive) is
      Workers   : Babel.Strategies.Workers.Worker_Type (Count);
      Container : Babel.Files.Default_Container;
      Queue     : Babel.Files.Queues.Directory_Queue;
   begin
      Babel.Files.Queues.Add_Directory (Queue, Dir);
      Babel.Strategies.Workers.Start (Workers, Backup'Unchecked_Access);
      Backup.Scan (Queue, Container);
   end Do_Backup;

begin
   Dir := Babel.Files.Allocate (Name => ".",
                                Dir  => Babel.Files.NO_DIRECTORY);
   Exclude.Add_Exclude (".svn");
   Exclude.Add_Exclude ("obj");
   Babel.Files.Buffers.Create_Pool (Into => Buffers, Count => 10, Size => 1_000_000);
   Store.Set_Root_Directory ("/tmp/babel-store");
   Local.Set_Root_Directory (".");
   Backup.Set_Filters (Exclude'Unchecked_Access);
   Backup.Set_Stores (Read => Local'Unchecked_Access, Write => Store'Unchecked_Access);
   Backup.Set_Buffers (Buffers'Unchecked_Access);

   Put_Line ("Size: " & Natural'Image (Ada.Directories.File_Size'Size));
   Do_Backup (2);
--     Bkp.Files.Scan (".", Dir);
--     Bkp.Files.Iterate_Files (".", Dir, 10, Print_Sha'Access);
--     Put_Line ("Total size: " & Ada.Directories.File_Size'Image (Dir.Tot_Size));
--     Put_Line ("File count: " & Natural'Image (Dir.Tot_Files));
--     Put_Line ("Dir count:  " & Natural'Image (Dir.Tot_Dirs));
end babel_main;

Update to use the new Scan procedure

Update to use the new Scan procedure


-----------------------------------------------------------------------
--  mat-targets-probes - Definition and Analysis of process start events
--  Copyright (C) 2014, 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 Bfd;
with ELF;
with MAT.Readers.Marshaller;
package body MAT.Targets.Probes is

   M_PID         : constant MAT.Events.Internal_Reference := 1;
   M_EXE         : constant MAT.Events.Internal_Reference := 2;
   M_HEAP_START  : constant MAT.Events.Internal_Reference := 3;
   M_HEAP_END    : constant MAT.Events.Internal_Reference := 4;
   M_END         : constant MAT.Events.Internal_Reference := 5;
   M_LIBNAME     : constant MAT.Events.Internal_Reference := 6;
   M_LADDR       : constant MAT.Events.Internal_Reference := 7;
   M_COUNT       : constant MAT.Events.Internal_Reference := 8;
   M_TYPE        : constant MAT.Events.Internal_Reference := 9;
   M_VADDR       : constant MAT.Events.Internal_Reference := 10;
   M_SIZE        : constant MAT.Events.Internal_Reference := 11;
   M_FLAGS       : constant MAT.Events.Internal_Reference := 12;

   PID_NAME      : aliased constant String := "pid";
   EXE_NAME      : aliased constant String := "exe";
   HP_START_NAME : aliased constant String := "hp_start";
   HP_END_NAME   : aliased constant String := "hp_end";
   END_NAME      : aliased constant String := "end";
   LIBNAME_NAME  : aliased constant String := "libname";
   LADDR_NAME    : aliased constant String := "laddr";
   COUNT_NAME    : aliased constant String := "count";
   TYPE_NAME     : aliased constant String := "type";
   VADDR_NAME    : aliased constant String := "vaddr";
   SIZE_NAME     : aliased constant String := "size";
   FLAGS_NAME    : aliased constant String := "flags";

   Process_Attributes : aliased constant MAT.Events.Attribute_Table :=
     (1 => (Name => PID_NAME'Access, Size => 0,
            Kind => MAT.Events.T_SIZE_T, Ref => M_PID),
      2 => (Name => EXE_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_EXE),
      3 => (Name => HP_START_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_HEAP_START),
      4 => (Name => HP_END_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_HEAP_END),
      5 => (Name => END_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_END));

   Library_Attributes : aliased constant MAT.Events.Attribute_Table :=
     (1 => (Name => LIBNAME_NAME'Access, Size => 0,
            Kind => MAT.Events.T_SIZE_T, Ref => M_LIBNAME),
      2 => (Name => LADDR_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_LADDR),
      3 => (Name => COUNT_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_COUNT),
      4 => (Name => TYPE_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_TYPE),
      5 => (Name => VADDR_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_VADDR),
      6 => (Name => SIZE_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_SIZE),
      7 => (Name => FLAGS_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_FLAGS));

   --  ------------------------------
   --  Create a new process after the begin event is received from the event stream.
   --  ------------------------------
   procedure Create_Process (Probe : in Process_Probe_Type;
                             Pid         : in MAT.Types.Target_Process_Ref;
                             Path        : in Ada.Strings.Unbounded.Unbounded_String) is
   begin
      Probe.Target.Create_Process (Pid     => Pid,
                                   Path    => Path,
                                   Process => Probe.Target.Current);
      Probe.Target.Process.Events := Probe.Events;
      MAT.Memory.Targets.Initialize (Memory  => Probe.Target.Process.Memory,
                                     Manager => Probe.Manager.all);
   end Create_Process;

   procedure Probe_Begin (Probe : in Process_Probe_Type;
                          Defs  : in MAT.Events.Attribute_Table;
                          Msg   : in out MAT.Readers.Message;
                          Event : in out MAT.Events.Target_Event_Type) is
      use type MAT.Types.Target_Addr;

      Pid  : MAT.Types.Target_Process_Ref := 0;
      Path : Ada.Strings.Unbounded.Unbounded_String;
      Heap : MAT.Memory.Region_Info;
   begin
      for I in Defs'Range loop
         declare
            Def : MAT.Events.Attribute renames Defs (I);
         begin
            case Def.Ref is
               when M_PID =>
                  Pid := MAT.Readers.Marshaller.Get_Target_Process_Ref (Msg, Def.Kind);

               when M_EXE =>
                  Path := MAT.Readers.Marshaller.Get_String (Msg);

               when M_HEAP_START =>
                  Heap.Start_Addr := MAT.Readers.Marshaller.Get_Target_Addr (Msg, Def.Kind);

               when M_HEAP_END =>
                  Heap.End_Addr := MAT.Readers.Marshaller.Get_Target_Addr (Msg, Def.Kind);

               when others =>
                  MAT.Readers.Marshaller.Skip (Msg, Def.Size);
            end case;
         end;
      end loop;
      Heap.Size  := Heap.End_Addr - Heap.Start_Addr;
      Heap.Path  := Ada.Strings.Unbounded.To_Unbounded_String ("[heap]");
      Event.Addr := Heap.Start_Addr;
      Event.Size := Heap.Size;
      Probe.Create_Process (Pid, Path);
      Probe.Manager.Read_Message (Msg);
      Probe.Manager.Read_Event_Definitions (Msg);
      Probe.Target.Process.Memory.Add_Region (Heap);
      Probe.Target.Process.Endian := MAT.Readers.Get_Endian (Msg);
   end Probe_Begin;

   --  ------------------------------
   --  Extract the information from the 'library' event.
   --  ------------------------------
   procedure Probe_Library (Probe : in Process_Probe_Type;
                            Defs  : in MAT.Events.Attribute_Table;
                            Msg   : in out MAT.Readers.Message;
                            Event : in out MAT.Events.Target_Event_Type) is
      use type MAT.Types.Target_Addr;

      Count : MAT.Types.Target_Size := 0;
      Path  : Ada.Strings.Unbounded.Unbounded_String;
      Addr  : MAT.Types.Target_Addr;
      Pos   : Natural := Defs'Last + 1;
      Offset : MAT.Types.Target_Addr;
   begin
      for I in Defs'Range loop
         declare
            Def : MAT.Events.Attribute renames Defs (I);
         begin
            case Def.Ref is
               when M_COUNT =>
                  Count := MAT.Readers.Marshaller.Get_Target_Size (Msg, Def.Kind);
                  Pos := I + 1;
                  exit;

               when M_LIBNAME =>
                  Path := MAT.Readers.Marshaller.Get_String (Msg);

               when M_LADDR =>
                  Addr := MAT.Readers.Marshaller.Get_Target_Addr (Msg, Def.Kind);

               when others =>
                  MAT.Readers.Marshaller.Skip (Msg, Def.Size);
            end case;
         end;
      end loop;
      Event.Addr := Addr;
      Event.Size := 0;
      for Region in 1 .. Count loop
         declare
            Region : MAT.Memory.Region_Info;
            Kind   : ELF.Elf32_Word := 0;
         begin
            for I in Pos .. Defs'Last loop
               declare
                  Def : MAT.Events.Attribute renames Defs (I);
               begin
                  case Def.Ref is
                  when M_SIZE =>
                     Region.Size := MAT.Readers.Marshaller.Get_Target_Size (Msg, Def.Kind);

                  when M_VADDR =>
                     Region.Start_Addr := MAT.Readers.Marshaller.Get_Target_Addr (Msg, Def.Kind);

                  when M_TYPE =>
                     Kind := MAT.Readers.Marshaller.Get_Target_Uint32 (Msg, Def.Kind);

                  when M_FLAGS =>
                     Region.Flags := MAT.Readers.Marshaller.Get_Target_Uint32 (Msg, Def.Kind);

                  when others =>
                     MAT.Readers.Marshaller.Skip (Msg, Def.Size);
                  end case;
               end;
            end loop;
            if Kind = ELF.PT_LOAD then
               Region.Start_Addr := Addr + Region.Start_Addr;
               Region.End_Addr   := Region.Start_Addr + Region.Size;
               if Ada.Strings.Unbounded.Length (Path) = 0 then
                  Region.Path := Probe.Target.Process.Path;
                  Offset := 0;
               else
                  Region.Path := Path;
                  Offset := Region.Start_Addr;
               end if;
               Event.Size := Event.Size + Region.Size;
               Probe.Target.Process.Memory.Add_Region (Region);

               --  When auto-symbol loading is enabled, load the symbols associated with the
               --  shared libraries used by the program.
               if Probe.Target.Options.Load_Symbols then
                  begin
                     Probe.Target.Process.Symbols.Value.Load_Symbols (Region, Offset);

                  exception
                     when Bfd.OPEN_ERROR =>
                        Probe.Target.Console.Error
                          ("Cannot open symbol library file '"
                           & Ada.Strings.Unbounded.To_String (Region.Path) & "'");
                  end;
               end if;
            end if;
         end;
      end loop;
   end Probe_Library;

   overriding
   procedure Extract (Probe  : in Process_Probe_Type;
                      Params : in MAT.Events.Const_Attribute_Table_Access;
                      Msg    : in out MAT.Readers.Message_Type;
                      Event  : in out MAT.Events.Target_Event_Type) is
      use type MAT.Events.Probe_Index_Type;
   begin
      if Event.Index = MAT.Events.MSG_BEGIN then
         Probe.Probe_Begin (Params.all, Msg, Event);
      elsif Event.Index = MAT.Events.MSG_LIBRARY then
         Probe.Probe_Library (Params.all, Msg, Event);
      end if;
   end Extract;

   procedure Execute (Probe : in Process_Probe_Type;
                      Event : in out MAT.Events.Target_Event_Type) is
   begin
      null;
   end Execute;

   --  ------------------------------
   --  Register the reader to extract and analyze process events.
   --  ------------------------------
   procedure Register (Into  : in out MAT.Events.Probes.Probe_Manager_Type'Class;
                       Probe : in Process_Probe_Type_Access) is
   begin
      Probe.Manager := Into'Unchecked_Access;
      Into.Register_Probe (Probe.all'Access, "begin", MAT.Events.MSG_BEGIN,
                           Process_Attributes'Access);
      Into.Register_Probe (Probe.all'Access, "end", MAT.Events.MSG_END,
                           Process_Attributes'Access);
      Into.Register_Probe (Probe.all'Access, "shlib", MAT.Events.MSG_LIBRARY,
                           Library_Attributes'Access);
   end Register;

   --  ------------------------------
   --  Initialize the target object to prepare for reading process events.
   --  ------------------------------
   procedure Initialize (Target  : in out Target_Type;
                         Manager : in out MAT.Events.Probes.Probe_Manager_Type'Class) is
      Process_Probe : constant Process_Probe_Type_Access
        := new Process_Probe_Type;
   begin
      Process_Probe.Target := Target'Unrestricted_Access;
      Process_Probe.Events := Manager.Get_Target_Events;
      Register (Manager, Process_Probe);
   end Initialize;

end MAT.Targets.Probes;

-----------------------------------------------------------------------
--  mat-targets-probes - Definition and Analysis of process start events
--  Copyright (C) 2014, 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 Bfd;
with ELF;

with MAT.Formats;
with MAT.Readers.Marshaller;
package body MAT.Targets.Probes is

   M_PID         : constant MAT.Events.Internal_Reference := 1;
   M_EXE         : constant MAT.Events.Internal_Reference := 2;
   M_HEAP_START  : constant MAT.Events.Internal_Reference := 3;
   M_HEAP_END    : constant MAT.Events.Internal_Reference := 4;
   M_END         : constant MAT.Events.Internal_Reference := 5;
   M_LIBNAME     : constant MAT.Events.Internal_Reference := 6;
   M_LADDR       : constant MAT.Events.Internal_Reference := 7;
   M_COUNT       : constant MAT.Events.Internal_Reference := 8;
   M_TYPE        : constant MAT.Events.Internal_Reference := 9;
   M_VADDR       : constant MAT.Events.Internal_Reference := 10;
   M_SIZE        : constant MAT.Events.Internal_Reference := 11;
   M_FLAGS       : constant MAT.Events.Internal_Reference := 12;

   PID_NAME      : aliased constant String := "pid";
   EXE_NAME      : aliased constant String := "exe";
   HP_START_NAME : aliased constant String := "hp_start";
   HP_END_NAME   : aliased constant String := "hp_end";
   END_NAME      : aliased constant String := "end";
   LIBNAME_NAME  : aliased constant String := "libname";
   LADDR_NAME    : aliased constant String := "laddr";
   COUNT_NAME    : aliased constant String := "count";
   TYPE_NAME     : aliased constant String := "type";
   VADDR_NAME    : aliased constant String := "vaddr";
   SIZE_NAME     : aliased constant String := "size";
   FLAGS_NAME    : aliased constant String := "flags";

   Process_Attributes : aliased constant MAT.Events.Attribute_Table :=
     (1 => (Name => PID_NAME'Access, Size => 0,
            Kind => MAT.Events.T_SIZE_T, Ref => M_PID),
      2 => (Name => EXE_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_EXE),
      3 => (Name => HP_START_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_HEAP_START),
      4 => (Name => HP_END_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_HEAP_END),
      5 => (Name => END_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_END));

   Library_Attributes : aliased constant MAT.Events.Attribute_Table :=
     (1 => (Name => LIBNAME_NAME'Access, Size => 0,
            Kind => MAT.Events.T_SIZE_T, Ref => M_LIBNAME),
      2 => (Name => LADDR_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_LADDR),
      3 => (Name => COUNT_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_COUNT),
      4 => (Name => TYPE_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_TYPE),
      5 => (Name => VADDR_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_VADDR),
      6 => (Name => SIZE_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_SIZE),
      7 => (Name => FLAGS_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_FLAGS));

   --  ------------------------------
   --  Create a new process after the begin event is received from the event stream.
   --  ------------------------------
   procedure Create_Process (Probe : in Process_Probe_Type;
                             Pid         : in MAT.Types.Target_Process_Ref;
                             Path        : in Ada.Strings.Unbounded.Unbounded_String) is
   begin
      Probe.Target.Create_Process (Pid     => Pid,
                                   Path    => Path,
                                   Process => Probe.Target.Current);
      Probe.Target.Process.Events := Probe.Events;
      MAT.Memory.Targets.Initialize (Memory  => Probe.Target.Process.Memory,
                                     Manager => Probe.Manager.all);
   end Create_Process;

   procedure Probe_Begin (Probe : in Process_Probe_Type;
                          Defs  : in MAT.Events.Attribute_Table;
                          Msg   : in out MAT.Readers.Message;
                          Event : in out MAT.Events.Target_Event_Type) is
      use type MAT.Types.Target_Addr;
      use type MAT.Events.Attribute_Type;

      Pid  : MAT.Types.Target_Process_Ref := 0;
      Path : Ada.Strings.Unbounded.Unbounded_String;
      Heap : MAT.Memory.Region_Info;
   begin
      for I in Defs'Range loop
         declare
            Def : MAT.Events.Attribute renames Defs (I);
         begin
            case Def.Ref is
               when M_PID =>
                  Pid := MAT.Readers.Marshaller.Get_Target_Process_Ref (Msg, Def.Kind);

               when M_EXE =>
                  Path := MAT.Readers.Marshaller.Get_String (Msg);

               when M_HEAP_START =>
                  Heap.Start_Addr := MAT.Readers.Marshaller.Get_Target_Addr (Msg, Def.Kind);

               when M_HEAP_END =>
                  Heap.End_Addr := MAT.Readers.Marshaller.Get_Target_Addr (Msg, Def.Kind);

               when others =>
                  MAT.Readers.Marshaller.Skip (Msg, Def.Size);
            end case;
         end;
      end loop;
      Heap.Size  := Heap.End_Addr - Heap.Start_Addr;
      Heap.Path  := Ada.Strings.Unbounded.To_Unbounded_String ("[heap]");
      Event.Addr := Heap.Start_Addr;
      Event.Size := Heap.Size;
      Probe.Create_Process (Pid, Path);
      Probe.Manager.Read_Message (Msg);
      Probe.Manager.Read_Event_Definitions (Msg);
      Probe.Target.Process.Memory.Add_Region (Heap);
      Probe.Target.Process.Endian := MAT.Readers.Get_Endian (Msg);
      if Probe.Manager.Get_Address_Size = MAT.Events.T_UINT32 then
         MAT.Formats.Set_Address_Size (8);
      else
         MAT.Formats.Set_Address_Size (16);
      end if;
   end Probe_Begin;

   --  ------------------------------
   --  Extract the information from the 'library' event.
   --  ------------------------------
   procedure Probe_Library (Probe : in Process_Probe_Type;
                            Defs  : in MAT.Events.Attribute_Table;
                            Msg   : in out MAT.Readers.Message;
                            Event : in out MAT.Events.Target_Event_Type) is
      use type MAT.Types.Target_Addr;

      Count : MAT.Types.Target_Size := 0;
      Path  : Ada.Strings.Unbounded.Unbounded_String;
      Addr  : MAT.Types.Target_Addr;
      Pos   : Natural := Defs'Last + 1;
      Offset : MAT.Types.Target_Addr;
   begin
      for I in Defs'Range loop
         declare
            Def : MAT.Events.Attribute renames Defs (I);
         begin
            case Def.Ref is
               when M_COUNT =>
                  Count := MAT.Readers.Marshaller.Get_Target_Size (Msg, Def.Kind);
                  Pos := I + 1;
                  exit;

               when M_LIBNAME =>
                  Path := MAT.Readers.Marshaller.Get_String (Msg);

               when M_LADDR =>
                  Addr := MAT.Readers.Marshaller.Get_Target_Addr (Msg, Def.Kind);

               when others =>
                  MAT.Readers.Marshaller.Skip (Msg, Def.Size);
            end case;
         end;
      end loop;
      Event.Addr := Addr;
      Event.Size := 0;
      for Region in 1 .. Count loop
         declare
            Region : MAT.Memory.Region_Info;
            Kind   : ELF.Elf32_Word := 0;
         begin
            for I in Pos .. Defs'Last loop
               declare
                  Def : MAT.Events.Attribute renames Defs (I);
               begin
                  case Def.Ref is
                  when M_SIZE =>
                     Region.Size := MAT.Readers.Marshaller.Get_Target_Size (Msg, Def.Kind);

                  when M_VADDR =>
                     Region.Start_Addr := MAT.Readers.Marshaller.Get_Target_Addr (Msg, Def.Kind);

                  when M_TYPE =>
                     Kind := MAT.Readers.Marshaller.Get_Target_Uint32 (Msg, Def.Kind);

                  when M_FLAGS =>
                     Region.Flags := MAT.Readers.Marshaller.Get_Target_Uint32 (Msg, Def.Kind);

                  when others =>
                     MAT.Readers.Marshaller.Skip (Msg, Def.Size);
                  end case;
               end;
            end loop;
            if Kind = ELF.PT_LOAD then
               Region.Start_Addr := Addr + Region.Start_Addr;
               Region.End_Addr   := Region.Start_Addr + Region.Size;
               if Ada.Strings.Unbounded.Length (Path) = 0 then
                  Region.Path := Probe.Target.Process.Path;
                  Offset := 0;
               else
                  Region.Path := Path;
                  Offset := Region.Start_Addr;
               end if;
               Event.Size := Event.Size + Region.Size;
               Probe.Target.Process.Memory.Add_Region (Region);

               --  When auto-symbol loading is enabled, load the symbols associated with the
               --  shared libraries used by the program.
               if Probe.Target.Options.Load_Symbols then
                  begin
                     Probe.Target.Process.Symbols.Value.Load_Symbols (Region, Offset);

                  exception
                     when Bfd.OPEN_ERROR =>
                        Probe.Target.Console.Error
                          ("Cannot open symbol library file '"
                           & Ada.Strings.Unbounded.To_String (Region.Path) & "'");
                  end;
               end if;
            end if;
         end;
      end loop;
   end Probe_Library;

   overriding
   procedure Extract (Probe  : in Process_Probe_Type;
                      Params : in MAT.Events.Const_Attribute_Table_Access;
                      Msg    : in out MAT.Readers.Message_Type;
                      Event  : in out MAT.Events.Target_Event_Type) is
      use type MAT.Events.Probe_Index_Type;
   begin
      if Event.Index = MAT.Events.MSG_BEGIN then
         Probe.Probe_Begin (Params.all, Msg, Event);
      elsif Event.Index = MAT.Events.MSG_LIBRARY then
         Probe.Probe_Library (Params.all, Msg, Event);
      end if;
   end Extract;

   procedure Execute (Probe : in Process_Probe_Type;
                      Event : in out MAT.Events.Target_Event_Type) is
   begin
      null;
   end Execute;

   --  ------------------------------
   --  Register the reader to extract and analyze process events.
   --  ------------------------------
   procedure Register (Into  : in out MAT.Events.Probes.Probe_Manager_Type'Class;
                       Probe : in Process_Probe_Type_Access) is
   begin
      Probe.Manager := Into'Unchecked_Access;
      Into.Register_Probe (Probe.all'Access, "begin", MAT.Events.MSG_BEGIN,
                           Process_Attributes'Access);
      Into.Register_Probe (Probe.all'Access, "end", MAT.Events.MSG_END,
                           Process_Attributes'Access);
      Into.Register_Probe (Probe.all'Access, "shlib", MAT.Events.MSG_LIBRARY,
                           Library_Attributes'Access);
   end Register;

   --  ------------------------------
   --  Initialize the target object to prepare for reading process events.
   --  ------------------------------
   procedure Initialize (Target  : in out Target_Type;
                         Manager : in out MAT.Events.Probes.Probe_Manager_Type'Class) is
      Process_Probe : constant Process_Probe_Type_Access
        := new Process_Probe_Type;
   begin
      Process_Probe.Target := Target'Unrestricted_Access;
      Process_Probe.Events := Manager.Get_Target_Events;
      Register (Manager, Process_Probe);
   end Initialize;

end MAT.Targets.Probes;

Configure the address format after we know addresses are 32-bit or 64-bit wide


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

package body Util.Concurrent.Counters is

   function Sync_Sub_And_Fetch (Ptr   : access Interfaces.Unsigned_32;
                                Value : in Interfaces.Unsigned_32) return Interfaces.Unsigned_32;
   pragma Import (Intrinsic, Sync_Sub_And_Fetch,
                  External_Name => "__sync_sub_and_fetch_4");

   function Sync_Fetch_And_Add (Ptr   : access Interfaces.Unsigned_32;
                                Value : in Interfaces.Unsigned_32) return Interfaces.Unsigned_32;
   pragma Import (Intrinsic, Sync_Fetch_And_Add,
                  External_Name => "__sync_fetch_and_add_4");

   procedure Sync_Add (Ptr   : access Interfaces.Unsigned_32;
                       Value : in Interfaces.Unsigned_32);
   pragma Import (Intrinsic, Sync_Add,
                  External_Name => "__sync_add_and_fetch_4");

   procedure Sync_Sub (Ptr   : access Interfaces.Unsigned_32;
                       Value : in Interfaces.Unsigned_32);
   pragma Import (Intrinsic, Sync_Sub,
                  External_Name => "__sync_sub_and_fetch_4");

   --  ------------------------------
   --  Increment the counter atomically.
   --  ------------------------------
   procedure Increment (C : in out Counter) is
   begin
      Sync_Add (C.Value'Unrestricted_Access, 1);
   end Increment;

   --  ------------------------------
   --  Increment the counter atomically and return the value before increment.
   --  ------------------------------
   procedure Increment (C     : in out Counter;
                        Value : out Integer) is
   begin
      Value := Integer (Sync_Fetch_And_Add (C.Value'Unrestricted_Access, 1));
   end Increment;

   --  ------------------------------
   --  Decrement the counter atomically.
   --  ------------------------------
   procedure Decrement (C : in out Counter) is
      use type Interfaces.Unsigned_32;
   begin
      Sync_Sub (C.Value'Unrestricted_Access, 1);
   end Decrement;

   --  ------------------------------
   --  Decrement the counter atomically and return a status.
   --  ------------------------------
   procedure Decrement (C : in out Counter;
                        Is_Zero : out Boolean) is
      use type Interfaces.Unsigned_32;

      Value : Interfaces.Unsigned_32;
   begin
      Value := Sync_Sub_And_Fetch (C.Value'Unrestricted_Access, 1);
      Is_Zero := Value = 0;
   end Decrement;

   --  ------------------------------
   --  Get the counter value
   --  ------------------------------
   function Value (C : in Counter) return Integer is
   begin
      return Integer (C.Value);
   end Value;

end Util.Concurrent.Counters;

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

package body Util.Concurrent.Counters is

   function Sync_Sub_And_Fetch (Ptr   : access Interfaces.Unsigned_32;
                                Value : in Interfaces.Unsigned_32) return Interfaces.Unsigned_32;
   pragma Import (Intrinsic, Sync_Sub_And_Fetch,
                  External_Name => "__sync_sub_and_fetch_4");

   function Sync_Fetch_And_Add (Ptr   : access Interfaces.Unsigned_32;
                                Value : in Interfaces.Unsigned_32) return Interfaces.Unsigned_32;
   pragma Import (Intrinsic, Sync_Fetch_And_Add,
                  External_Name => "__sync_fetch_and_add_4");

   procedure Sync_Add (Ptr   : access Interfaces.Unsigned_32;
                       Value : in Interfaces.Unsigned_32);
   pragma Import (Intrinsic, Sync_Add,
                  External_Name => "__sync_add_and_fetch_4");

   procedure Sync_Sub (Ptr   : access Interfaces.Unsigned_32;
                       Value : in Interfaces.Unsigned_32);
   pragma Import (Intrinsic, Sync_Sub,
                  External_Name => "__sync_sub_and_fetch_4");

   --  ------------------------------
   --  Increment the counter atomically.
   --  ------------------------------
   procedure Increment (C : in out Counter) is
   begin
      Sync_Add (C.Value'Unrestricted_Access, 1);
   end Increment;

   --  ------------------------------
   --  Increment the counter atomically and return the value before increment.
   --  ------------------------------
   procedure Increment (C     : in out Counter;
                        Value : out Integer) is
   begin
      Value := Integer (Sync_Fetch_And_Add (C.Value'Unrestricted_Access, 1));
   end Increment;

   --  ------------------------------
   --  Decrement the counter atomically.
   --  ------------------------------
   procedure Decrement (C : in out Counter) is
   begin
      Sync_Sub (C.Value'Unrestricted_Access, 1);
   end Decrement;

   --  ------------------------------
   --  Decrement the counter atomically and return a status.
   --  ------------------------------
   procedure Decrement (C : in out Counter;
                        Is_Zero : out Boolean) is
      use type Interfaces.Unsigned_32;

      Value : Interfaces.Unsigned_32;
   begin
      Value := Sync_Sub_And_Fetch (C.Value'Unrestricted_Access, 1);
      Is_Zero := Value = 0;
   end Decrement;

   --  ------------------------------
   --  Get the counter value
   --  ------------------------------
   function Value (C : in Counter) return Integer is
   begin
      return Integer (C.Value);
   end Value;

end Util.Concurrent.Counters;

Remove unecessary use type clause in Decrement