-----------------------------------------------------------------------
--  akt-commands-info -- Info command to describe the current configuration
--  Copyright (C) 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.
-----------------------------------------------------------------------
package body AWA.Commands.Info is

   use type AWA.Modules.Module_Access;

   --  ------------------------------
   --  Print the configuration identified by the given name.
   --  ------------------------------
   procedure Print (Command     : in out Command_Type;
                    Name        : in String;
                    Value       : in String;
                    Default     : in String;
                    Context     : in out Context_Type) is
      pragma Unreferenced (Default);

      Pos   : Natural;
   begin
      Context.Console.Start_Row;
      Context.Console.Print_Field (1, Name);
      Pos := Value'First;
      while Pos <= Value'Last loop
         if Value'Last - Pos > Command.Value_Length then
            Context.Console.Print_Field (2, Value (Pos .. Pos + Command.Value_Length - 1));
            Pos := Pos + Command.Value_Length;
            Context.Console.End_Row;
            Context.Console.Start_Row;
            Context.Console.Print_Field (1, "");
         else
            Context.Console.Print_Field (2, Value (Pos .. Value'Last));
            Pos := Pos + Value'Length;
         end if;
      end loop;
      Context.Console.End_Row;
   end Print;

   procedure Print (Command     : in out Command_Type;
                    Application : in out AWA.Applications.Application'Class;
                    Name        : in String;
                    Default     : in String;
                    Context     : in out Context_Type) is
      Value : constant String := Application.Get_Init_Parameter (Name, Default);
   begin
      Command.Print (Name, Value, Default, Context);
   end Print;

   procedure Print (Command     : in out Command_Type;
                    Module      : in AWA.Modules.Module'Class;
                    Name        : in String;
                    Default     : in String;
                    Context     : in out Context_Type) is
      Value : constant String := Module.Get_Config (Name, Default);
   begin
      Command.Print (Module.Get_Name & "." & Name, Value, Default, Context);
   end Print;

   --  ------------------------------
   --  Print the configuration about the application.
   --  ------------------------------
   overriding
   procedure Execute (Command     : in out Command_Type;
                      Application : in out AWA.Applications.Application'Class;
                      Args        : in Argument_List'Class;
                      Context     : in out Context_Type) is
      pragma Unreferenced (Args);

      Module : AWA.Modules.Module_Access;
   begin
      if Command.Long_List then
         Command.Value_Length := Natural'Last;
      end if;
      Application.Load_Bundle (Name   => "commands",
                               Locale => "en",
                               Bundle => Command.Bundle);

      Context.Console.Start_Title;
      Context.Console.Print_Title (1, "", 30);
      Context.Console.Print_Title (2, "", Command.Value_Length);
      Context.Console.End_Title;
      Context.Console.Notice (N_INFO, "Database configuration");
      Context.Console.Notice (N_INFO, "----------------------");

      Command.Print (Application, "database", "", Context);
      Command.Print (Application, "ado.queries.paths", "", Context);
      Command.Print (Application, "ado.queries.load", "", Context);
      Command.Print (Application, "ado.drivers.load", "", Context);

      Context.Console.Start_Title;
      Context.Console.Print_Title (1, "", 30);
      Context.Console.Print_Title (2, "", Command.Value_Length);
      Context.Console.End_Title;
      Context.Console.Notice (N_INFO, "Server faces configuration");
      Context.Console.Notice (N_INFO, "--------------------------");

      Command.Print (Application, "view.dir",
                     ASF.Applications.DEF_VIEW_DIR, Context);
      Command.Print (Application, "view.escape_unknown_tags",
                     ASF.Applications.DEF_ESCAPE_UNKNOWN_TAGS, Context);
      Command.Print (Application, "view.ext",
                     ASF.Applications.DEF_VIEW_EXT, Context);
      Command.Print (Application, "view.file_ext",
                     ASF.Applications.DEF_VIEW_FILE_EXT, Context);
      Command.Print (Application, "view.ignore_spaces",
                     ASF.Applications.DEF_IGNORE_WHITE_SPACES, Context);
      Command.Print (Application, "view.ignore_empty_lines",
                     ASF.Applications.DEF_IGNORE_EMPTY_LINES, Context);
      Command.Print (Application, "view.static.dir",
                     ASF.Applications.DEF_STATIC_DIR, Context);
      Command.Print (Application, "bundle.dir", "bundles", Context);

      Context.Console.Start_Title;
      Context.Console.Print_Title (1, "", 30);
      Context.Console.Print_Title (2, "", Command.Value_Length);
      Context.Console.End_Title;
      Context.Console.Notice (N_INFO, "AWA Application");
      Context.Console.Notice (N_INFO, "--------------------------");
      Command.Print (Application, "app_name", "", Context);
      Command.Print (Application, "app_search_dirs", ".", Context);
      Command.Print (Application, "app.modules.dir", "", Context);
      Command.Print (Application, "app_url_base", "", Context);
      Command.Print (Application, "awa_url_host", "", Context);
      Command.Print (Application, "awa_url_port", "", Context);
      Command.Print (Application, "awa_url_scheme", "", Context);
      Command.Print (Application, "app.config", "awa.xml", Context);
      Command.Print (Application, "app.config.plugins", "", Context);
      Command.Print (Application, "contextPath", "", Context);
      Command.Print (Application, "awa_dispatcher_count", "", Context);
      Command.Print (Application, "awa_dispatcher_priority", "", Context);

      Module := Application.Find_Module ("users");
      if Module /= null then
         Context.Console.Start_Title;
         Context.Console.Print_Title (1, "", 30);
         Context.Console.Print_Title (2, "", Command.Value_Length);
         Context.Console.End_Title;
         Context.Console.Notice (N_INFO, "Users Module");
         Context.Console.Notice (N_INFO, "------------");
         Command.Print (Application, "openid.realm", "", Context);
         Command.Print (Application, "openid.callback_url", "", Context);
         Command.Print (Application, "openid.success_url", "", Context);
         Command.Print (Application, "auth.url.orange", "", Context);
         Command.Print (Application, "auth.provider.orange", "", Context);
         Command.Print (Application, "auth.url.yahoo", "", Context);
         Command.Print (Application, "auth.provider.yahoo", "", Context);
         Command.Print (Application, "auth.url.google", "", Context);
         Command.Print (Application, "auth.provider.google", "", Context);
         Command.Print (Application, "auth.url.facebook", "", Context);
         Command.Print (Application, "auth.provider.facebook", "", Context);
         Command.Print (Application, "auth.url.google-plus", "", Context);
         Command.Print (Application, "auth.provider.google-plus", "", Context);
         Command.Print (Application, "facebook.callback_url", "", Context);
         Command.Print (Application, "facebook.request_url", "", Context);
         Command.Print (Application, "facebook.scope", "", Context);
         Command.Print (Application, "facebook.client_id", "", Context);
         Command.Print (Application, "facebook.secret", "", Context);
         Command.Print (Application, "google-plus.issuer", "", Context);
         Command.Print (Application, "google-plus.callback_url", "", Context);
         Command.Print (Application, "google-plus.request_url", "", Context);
         Command.Print (Application, "google-plus.scope", "", Context);
         Command.Print (Application, "google-plus.client_id", "", Context);
         Command.Print (Application, "google-plus.secret", "", Context);
         Command.Print (Application, "auth-filter.redirect", "", Context);
         Command.Print (Application, "verify-filter.redirect", "", Context);
      end if;

      Module := Application.Find_Module ("mail");
      if Module /= null then
         Context.Console.Start_Title;
         Context.Console.Print_Title (1, "", 30);
         Context.Console.Print_Title (2, "", Command.Value_Length);
         Context.Console.End_Title;
         Context.Console.Notice (N_INFO, "Mail Module");
         Context.Console.Notice (N_INFO, "-----------");
         Command.Print (Application, "mail.smtp.host", "", Context);
         Command.Print (Application, "mail.smtp.port", "", Context);
         Command.Print (Application, "mail.smtp.enable", "true", Context);
         Command.Print (Application, "mail.mailer", "smtp", Context);
         Command.Print (Application, "mail.file.maildir", "mail", Context);
         Command.Print (Application, "app_mail_name", "", Context);
         Command.Print (Application, "app_mail_from", "", Context);
      end if;

      Module := Application.Find_Module ("workspaces");
      if Module /= null then
         Context.Console.Start_Title;
         Context.Console.Print_Title (1, "", 30);
         Context.Console.Print_Title (2, "", Command.Value_Length);
         Context.Console.End_Title;
         Context.Console.Notice (N_INFO, "Workspace Module");
         Context.Console.Notice (N_INFO, "----------------");
         Command.Print (Module.all, "permissions_list", "", Context);
         Command.Print (Module.all, "allow_workspace_create", "", Context);
      end if;

      Module := Application.Find_Module ("storages");
      if Module /= null then
         Context.Console.Start_Title;
         Context.Console.Print_Title (1, "", 30);
         Context.Console.Print_Title (2, "", Command.Value_Length);
         Context.Console.End_Title;
         Context.Console.Notice (N_INFO, "Storage Module");
         Context.Console.Notice (N_INFO, "--------------------------");
         Command.Print (Module.all, "database_max_size", "100000", Context);
         Command.Print (Module.all, "storage_root", "storage", Context);
         Command.Print (Module.all, "tmp_storage_root", "tmp", Context);
         Module := Application.Find_Module ("images");
         if Module /= null then
            Command.Print (Module.all, "thumbnail_command", "", Context);
         end if;
      end if;

      Module := Application.Find_Module ("wikis");
      if Module /= null then
         Context.Console.Start_Title;
         Context.Console.Print_Title (1, "", 30);
         Context.Console.Print_Title (2, "", Command.Value_Length);
         Context.Console.End_Title;
         Context.Console.Notice (N_INFO, "Wiki Module");
         Context.Console.Notice (N_INFO, "-----------");
         Command.Print (Module.all, "image_prefix", "", Context);
         Command.Print (Module.all, "page_prefix", "", Context);
         Command.Print (Module.all, "wiki_copy_list", "", Context);
         Module := Application.Find_Module ("wiki_previews");
         if Module /= null then
            Command.Print (Module.all, "wiki_preview_tmp", "tmp", Context);
            Command.Print (Module.all, "wiki_preview_dir", "web/preview", Context);
            Command.Print (Module.all, "wiki_preview_template", "", Context);
            Command.Print (Module.all, "wiki_preview_html", "", Context);
            Command.Print (Module.all, "wiki_preview_command", "", Context);
         end if;
      end if;

      Module := Application.Find_Module ("counters");
      if Module /= null then
         Context.Console.Start_Title;
         Context.Console.Print_Title (1, "", 30);
         Context.Console.Print_Title (2, "", Command.Value_Length);
         Context.Console.End_Title;
         Context.Console.Notice (N_INFO, "Counter Module");
         Context.Console.Notice (N_INFO, "--------------");
         Command.Print (Module.all, "counter_age_limit", "300", Context);
         Command.Print (Module.all, "counter_limit", "1000", Context);
      end if;
   end Execute;

   --  ------------------------------
   --  Setup the command before parsing the arguments and executing it.
   --  ------------------------------
   overriding
   procedure Setup (Command : in out Command_Type;
                    Config  : in out GNAT.Command_Line.Command_Line_Configuration;
                    Context : in out Context_Type) is
   begin
      GC.Set_Usage (Config => Config,
                    Usage  => Command.Get_Name & " [arguments]",
                    Help   => Command.Get_Description);
      Command_Drivers.Application_Command_Type (Command).Setup (Config, Context);
      GC.Define_Switch (Config => Config,
                        Output => Command.Long_List'Access,
                        Switch => "-l",
                        Long_Switch => "--long-lines",
                        Help   => -("Use long lines to print configuration values"));
   end Setup;

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

begin
   Command_Drivers.Driver.Add_Command ("info",
                                       -("report configuration information"),
                                       Command'Access);
end AWA.Commands.Info;

-----------------------------------------------------------------------
--  akt-commands-info -- Info command to describe the current configuration
--  Copyright (C) 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.
-----------------------------------------------------------------------
package body AWA.Commands.Info is

   use type AWA.Modules.Module_Access;

   --  ------------------------------
   --  Print the configuration identified by the given name.
   --  ------------------------------
   procedure Print (Command     : in out Command_Type;
                    Name        : in String;
                    Value       : in String;
                    Default     : in String;
                    Context     : in out Context_Type) is
      pragma Unreferenced (Default);

      Pos   : Natural;
   begin
      Context.Console.Start_Row;
      Context.Console.Print_Field (1, Name);
      Pos := Value'First;
      while Pos <= Value'Last loop
         if Value'Last - Pos > Command.Value_Length then
            Context.Console.Print_Field (2, Value (Pos .. Pos + Command.Value_Length - 1));
            Pos := Pos + Command.Value_Length;
            Context.Console.End_Row;
            Context.Console.Start_Row;
            Context.Console.Print_Field (1, "");
         else
            Context.Console.Print_Field (2, Value (Pos .. Value'Last));
            Pos := Pos + Value'Length;
         end if;
      end loop;
      Context.Console.End_Row;
   end Print;

   procedure Print (Command     : in out Command_Type;
                    Application : in out AWA.Applications.Application'Class;
                    Name        : in String;
                    Default     : in String;
                    Context     : in out Context_Type) is
      Value : constant String := Application.Get_Init_Parameter (Name, Default);
   begin
      Command.Print (Name, Value, Default, Context);
   end Print;

   procedure Print (Command     : in out Command_Type;
                    Module      : in AWA.Modules.Module'Class;
                    Name        : in String;
                    Default     : in String;
                    Context     : in out Context_Type) is
      Value : constant String := Module.Get_Config (Name, Default);
   begin
      Command.Print (Module.Get_Name & "." & Name, Value, Default, Context);
   end Print;

   --  ------------------------------
   --  Print the configuration about the application.
   --  ------------------------------
   overriding
   procedure Execute (Command     : in out Command_Type;
                      Application : in out AWA.Applications.Application'Class;
                      Args        : in Argument_List'Class;
                      Context     : in out Context_Type) is
      pragma Unreferenced (Args);

      Module : AWA.Modules.Module_Access;
   begin
      if Command.Long_List then
         Command.Value_Length := Natural'Last;
      end if;
      Application.Load_Bundle (Name   => "commands",
                               Locale => "en",
                               Bundle => Command.Bundle);

      Context.Console.Start_Title;
      Context.Console.Print_Title (1, "", 30);
      Context.Console.Print_Title (2, "", Command.Value_Length);
      Context.Console.End_Title;
      Context.Console.Notice (N_INFO, "Database configuration");
      Context.Console.Notice (N_INFO, "----------------------");

      Command.Print (Application, "database", "", Context);
      Command.Print (Application, "ado.queries.paths", "", Context);
      Command.Print (Application, "ado.queries.load", "", Context);
      Command.Print (Application, "ado.drivers.load", "", Context);

      Context.Console.Start_Title;
      Context.Console.Print_Title (1, "", 30);
      Context.Console.Print_Title (2, "", Command.Value_Length);
      Context.Console.End_Title;
      Context.Console.Notice (N_INFO, "Server faces configuration");
      Context.Console.Notice (N_INFO, "--------------------------");

      Command.Print (Application, "view.dir",
                     ASF.Applications.DEF_VIEW_DIR, Context);
      Command.Print (Application, "view.escape_unknown_tags",
                     ASF.Applications.DEF_ESCAPE_UNKNOWN_TAGS, Context);
      Command.Print (Application, "view.ext",
                     ASF.Applications.DEF_VIEW_EXT, Context);
      Command.Print (Application, "view.file_ext",
                     ASF.Applications.DEF_VIEW_FILE_EXT, Context);
      Command.Print (Application, "view.ignore_spaces",
                     ASF.Applications.DEF_IGNORE_WHITE_SPACES, Context);
      Command.Print (Application, "view.ignore_empty_lines",
                     ASF.Applications.DEF_IGNORE_EMPTY_LINES, Context);
      Command.Print (Application, "view.static.dir",
                     ASF.Applications.DEF_STATIC_DIR, Context);
      Command.Print (Application, "bundle.dir", "bundles", Context);

      Context.Console.Start_Title;
      Context.Console.Print_Title (1, "", 30);
      Context.Console.Print_Title (2, "", Command.Value_Length);
      Context.Console.End_Title;
      Context.Console.Notice (N_INFO, "AWA Application");
      Context.Console.Notice (N_INFO, "--------------------------");
      Command.Print (Application, "app_name", "", Context);
      Command.Print (Application, "app_search_dirs", ".", Context);
      Command.Print (Application, "app.modules.dir", "", Context);
      Command.Print (Application, "app_url_base", "", Context);
      Command.Print (Application, "awa_url_host", "", Context);
      Command.Print (Application, "awa_url_port", "", Context);
      Command.Print (Application, "awa_url_scheme", "", Context);
      Command.Print (Application, "app.config", "awa.xml", Context);
      Command.Print (Application, "app.config.plugins", "", Context);
      Command.Print (Application, "contextPath", "", Context);
      Command.Print (Application, "awa_dispatcher_count", "", Context);
      Command.Print (Application, "awa_dispatcher_priority", "", Context);

      Module := Application.Find_Module ("users");
      if Module /= null then
         Context.Console.Start_Title;
         Context.Console.Print_Title (1, "", 30);
         Context.Console.Print_Title (2, "", Command.Value_Length);
         Context.Console.End_Title;
         Context.Console.Notice (N_INFO, "Users Module");
         Context.Console.Notice (N_INFO, "------------");
         Command.Print (Application, "openid.realm", "", Context);
         Command.Print (Application, "openid.callback_url", "", Context);
         Command.Print (Application, "openid.success_url", "", Context);
         Command.Print (Application, "auth.url.orange", "", Context);
         Command.Print (Application, "auth.provider.orange", "", Context);
         Command.Print (Application, "auth.url.yahoo", "", Context);
         Command.Print (Application, "auth.provider.yahoo", "", Context);
         Command.Print (Application, "auth.url.google", "", Context);
         Command.Print (Application, "auth.provider.google", "", Context);
         Command.Print (Application, "auth.url.facebook", "", Context);
         Command.Print (Application, "auth.provider.facebook", "", Context);
         Command.Print (Application, "auth.url.google-plus", "", Context);
         Command.Print (Application, "auth.provider.google-plus", "", Context);
         Command.Print (Application, "facebook.callback_url", "", Context);
         Command.Print (Application, "facebook.request_url", "", Context);
         Command.Print (Application, "facebook.scope", "", Context);
         Command.Print (Application, "facebook.client_id", "", Context);
         Command.Print (Application, "facebook.secret", "", Context);
         Command.Print (Application, "google-plus.issuer", "", Context);
         Command.Print (Application, "google-plus.callback_url", "", Context);
         Command.Print (Application, "google-plus.request_url", "", Context);
         Command.Print (Application, "google-plus.scope", "", Context);
         Command.Print (Application, "google-plus.client_id", "", Context);
         Command.Print (Application, "google-plus.secret", "", Context);
         Command.Print (Application, "auth-filter.redirect", "", Context);
         Command.Print (Application, "verify-filter.redirect", "", Context);
         Command.Print (Application, "users.auth_key", "", Context);
         Command.Print (Application, "users.server_id", "", Context);
      end if;

      Module := Application.Find_Module ("mail");
      if Module /= null then
         Context.Console.Start_Title;
         Context.Console.Print_Title (1, "", 30);
         Context.Console.Print_Title (2, "", Command.Value_Length);
         Context.Console.End_Title;
         Context.Console.Notice (N_INFO, "Mail Module");
         Context.Console.Notice (N_INFO, "-----------");
         Command.Print (Application, "mail.smtp.host", "", Context);
         Command.Print (Application, "mail.smtp.port", "", Context);
         Command.Print (Application, "mail.smtp.enable", "true", Context);
         Command.Print (Application, "mail.mailer", "smtp", Context);
         Command.Print (Application, "mail.file.maildir", "mail", Context);
         Command.Print (Application, "app_mail_name", "", Context);
         Command.Print (Application, "app_mail_from", "", Context);
      end if;

      Module := Application.Find_Module ("workspaces");
      if Module /= null then
         Context.Console.Start_Title;
         Context.Console.Print_Title (1, "", 30);
         Context.Console.Print_Title (2, "", Command.Value_Length);
         Context.Console.End_Title;
         Context.Console.Notice (N_INFO, "Workspace Module");
         Context.Console.Notice (N_INFO, "----------------");
         Command.Print (Module.all, "permissions_list", "", Context);
         Command.Print (Module.all, "allow_workspace_create", "", Context);
      end if;

      Module := Application.Find_Module ("storages");
      if Module /= null then
         Context.Console.Start_Title;
         Context.Console.Print_Title (1, "", 30);
         Context.Console.Print_Title (2, "", Command.Value_Length);
         Context.Console.End_Title;
         Context.Console.Notice (N_INFO, "Storage Module");
         Context.Console.Notice (N_INFO, "--------------------------");
         Command.Print (Module.all, "database_max_size", "100000", Context);
         Command.Print (Module.all, "storage_root", "storage", Context);
         Command.Print (Module.all, "tmp_storage_root", "tmp", Context);
         Module := Application.Find_Module ("images");
         if Module /= null then
            Command.Print (Module.all, "thumbnail_command", "", Context);
         end if;
      end if;

      Module := Application.Find_Module ("wikis");
      if Module /= null then
         Context.Console.Start_Title;
         Context.Console.Print_Title (1, "", 30);
         Context.Console.Print_Title (2, "", Command.Value_Length);
         Context.Console.End_Title;
         Context.Console.Notice (N_INFO, "Wiki Module");
         Context.Console.Notice (N_INFO, "-----------");
         Command.Print (Module.all, "image_prefix", "", Context);
         Command.Print (Module.all, "page_prefix", "", Context);
         Command.Print (Module.all, "wiki_copy_list", "", Context);
         Module := Application.Find_Module ("wiki_previews");
         if Module /= null then
            Command.Print (Module.all, "wiki_preview_tmp", "tmp", Context);
            Command.Print (Module.all, "wiki_preview_dir", "web/preview", Context);
            Command.Print (Module.all, "wiki_preview_template", "", Context);
            Command.Print (Module.all, "wiki_preview_html", "", Context);
            Command.Print (Module.all, "wiki_preview_command", "", Context);
         end if;
      end if;

      Module := Application.Find_Module ("counters");
      if Module /= null then
         Context.Console.Start_Title;
         Context.Console.Print_Title (1, "", 30);
         Context.Console.Print_Title (2, "", Command.Value_Length);
         Context.Console.End_Title;
         Context.Console.Notice (N_INFO, "Counter Module");
         Context.Console.Notice (N_INFO, "--------------");
         Command.Print (Module.all, "counter_age_limit", "300", Context);
         Command.Print (Module.all, "counter_limit", "1000", Context);
      end if;
   end Execute;

   --  ------------------------------
   --  Setup the command before parsing the arguments and executing it.
   --  ------------------------------
   overriding
   procedure Setup (Command : in out Command_Type;
                    Config  : in out GNAT.Command_Line.Command_Line_Configuration;
                    Context : in out Context_Type) is
   begin
      GC.Set_Usage (Config => Config,
                    Usage  => Command.Get_Name & " [arguments]",
                    Help   => Command.Get_Description);
      Command_Drivers.Application_Command_Type (Command).Setup (Config, Context);
      GC.Define_Switch (Config => Config,
                        Output => Command.Long_List'Access,
                        Switch => "-l",
                        Long_Switch => "--long-lines",
                        Help   => -("Use long lines to print configuration values"));
   end Setup;

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

begin
   Command_Drivers.Driver.Add_Command ("info",
                                       -("report configuration information"),
                                       Command'Access);
end AWA.Commands.Info;

Print the user module configuration

Print the user module configuration


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

with Util.Strings;
with Util.Log.Loggers;
with Util.Http.Clients.Curl.Constants;
package body Util.Http.Clients.Curl is

   use System;

   pragma Linker_Options ("-lcurl");

   Log   : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Util.Http.Clients.Curl");

   function Get_Request (Http : in Client'Class) return Curl_Http_Request_Access;

   PUT_TOKEN    : constant Chars_Ptr := Strings.New_String ("PUT");
   DELETE_TOKEN : constant Chars_Ptr := Strings.New_String ("DELETE");
   Manager      : aliased Curl_Http_Manager;

   --  ------------------------------
   --  Register the CURL Http manager.
   --  ------------------------------
   procedure Register is
   begin
      Default_Http_Manager := Manager'Access;
   end Register;

   --  ------------------------------
   --  Check the CURL result code and report and exception and a log message if
   --  the CURL code indicates an error.
   --  ------------------------------
   procedure Check_Code (Code    : in CURL_Code;
                         Message : in String) is
   begin
      if Code /= CURLE_OK then
         declare
            Error : constant Chars_Ptr := Curl_Easy_Strerror (Code);
            Msg   : constant String := Interfaces.C.Strings.Value (Error);
         begin
            Log.Error ("{0}: {1}", Message, Msg);
            raise Connection_Error with Msg;
         end;
      end if;
   end Check_Code;

   --  ------------------------------
   --  Create a new HTTP request associated with the current request manager.
   --  ------------------------------
   procedure Create (Manager  : in Curl_Http_Manager;
                     Http     : in out Client'Class) is
      pragma Unreferenced (Manager);

      Request : Curl_Http_Request_Access;
      Data    : CURL;
   begin
      Data := Curl_Easy_Init;
      if Data = System.Null_Address then
         raise Storage_Error with "curl_easy_init cannot create the CURL instance";
      end if;
      Request := new Curl_Http_Request;
      Request.Data  := Data;
      Http.Delegate := Request.all'Access;
   end Create;

   function Get_Request (Http : in Client'Class) return Curl_Http_Request_Access is
   begin
      return Curl_Http_Request'Class (Http.Delegate.all)'Access;
   end Get_Request;

   --  ------------------------------
   --  This function is called by CURL when a response line was read.
   --  ------------------------------
   function Read_Response (Data     : in Chars_Ptr;
                           Size     : in Size_T;
                           Nmemb    : in Size_T;
                           Response : in Curl_Http_Response_Access) return Size_T is

      Total : constant Size_T := Size * Nmemb;
      Line  : constant String := Interfaces.C.Strings.Value (Data, Total);
   begin
      Log.Info ("RCV: {0}", Line);
      if Response.Parsing_Body then
         Ada.Strings.Unbounded.Append (Response.Content, Line);

      elsif Total = 2 and then Line (1) = ASCII.CR and then Line (2) = ASCII.LF then
         Response.Parsing_Body := True;

      else
         declare
            Pos   : constant Natural := Util.Strings.Index (Line, ':');
            Start : Natural;
            Last  : Natural;
         begin
            if Pos > 0 then
               Start := Pos + 1;
               while Start <= Line'Last and Line (Start) = ' ' loop
                  Start := Start + 1;
               end loop;
               Last := Line'Last;
               while Last >= Start and (Line (Last) = ASCII.CR or Line (Last) = ASCII.LF) loop
                  Last := Last - 1;
               end loop;
               Response.Add_Header (Name  => Line (Line'First .. Pos - 1),
                                    Value => Line (Start .. Last));
            end if;
         end;
      end if;
      return Total;
   end Read_Response;

   --  ------------------------------
   --  Prepare to setup the headers in the request.
   --  ------------------------------
   procedure Set_Headers (Request : in out Curl_Http_Request) is

      procedure Process (Name, Value : in String) is
         S : Chars_Ptr := Strings.New_String (Name & ": " & Value);
      begin
         Request.Curl_Headers := Curl_Slist_Append (Request.Curl_Headers, S);
         Interfaces.C.Strings.Free (S);
      end Process;

   begin
      if Request.Curl_Headers /= null then
         Curl_Slist_Free_All (Request.Curl_Headers);
         Request.Curl_Headers := null;
      end if;

      Request.Iterate_Headers (Process'Access);
   end Set_Headers;

   procedure Do_Get (Manager  : in Curl_Http_Manager;
                     Http     : in Client'Class;
                     URI      : in String;
                     Reply    : out Response'Class) is
      pragma Unreferenced (Manager);
      use Interfaces.C;

      Req      : constant Curl_Http_Request_Access := Get_Request (Http);
      Result   : CURL_Code;
      Response : Curl_Http_Response_Access;
      Status   : aliased C.long;
   begin
      Log.Info ("GET {0}", URI);
      Result := Curl_Easy_Setopt_Write_Callback (Req.Data, Constants.CURLOPT_WRITEUNCTION,
                                                 Read_Response'Access);
      Check_Code (Result, "set callback");

      Req.Set_Headers;

      Interfaces.C.Strings.Free (Req.URL);
      Req.URL := Strings.New_String (URI);

      Result := Curl_Easy_Setopt_Long (Req.Data, Constants.CURLOPT_HTTPGET, 1);
      Check_Code (Result, "set http GET");

      Result := Curl_Easy_Setopt_Long (Req.Data, Constants.CURLOPT_HEADER, 1);
      Check_Code (Result, "set header");

      Result := Curl_Easy_Setopt_Slist (Req.Data, Constants.CURLOPT_HTTPHEADER, Req.Curl_Headers);
      Check_Code (Result, "set http GET headers");

      Result := Curl_Easy_Setopt_String (Req.Data, Constants.CURLOPT_URL, Req.URL);
      Check_Code (Result, "set url");

      Response := new Curl_Http_Response;
      Result := Curl_Easy_Setopt_Data (Req.Data, Constants.CURLOPT_WRITEDATA, Response);
      Check_Code (Result, "set write data");
      Reply.Delegate := Response.all'Access;

      Result := Curl_Easy_Perform (Req.Data);
      Check_Code (Result, "get request");

      Result := Curl_Easy_Getinfo_Long (Req.Data, Constants.CURLINFO_RESPONSE_CODE, Status'Access);
      Check_Code (Result, "get response code");
      Response.Status := Natural (Status);
   end Do_Get;

   procedure Do_Post (Manager  : in Curl_Http_Manager;
                      Http     : in Client'Class;
                      URI      : in String;
                      Data     : in String;
                      Reply    : out Response'Class) is
      pragma Unreferenced (Manager);
      use Interfaces.C;

      Req      : constant Curl_Http_Request_Access := Get_Request (Http);
      Result   : CURL_Code;
      Response : Curl_Http_Response_Access;
      Status   : aliased C.long;
   begin
      Log.Info ("POST {0}", URI);

      Result := Curl_Easy_Setopt_Write_Callback (Req.Data, Constants.CURLOPT_WRITEUNCTION,
                                                 Read_Response'Access);
      Check_Code (Result, "set callback");
      Req.Set_Headers;

      Interfaces.C.Strings.Free (Req.URL);
      Req.URL := Strings.New_String (URI);

      Interfaces.C.Strings.Free (Req.Content);
      Req.Content := Strings.New_String (Data);

      Result := Curl_Easy_Setopt_Long (Req.Data, Constants.CURLOPT_POST, 1);
      Check_Code (Result, "set http POST");

      Result := Curl_Easy_Setopt_Long (Req.Data, Constants.CURLOPT_HEADER, 1);
      Check_Code (Result, "set header");

      Result := Curl_Easy_Setopt_Slist (Req.Data, Constants.CURLOPT_HTTPHEADER, Req.Curl_Headers);
      Check_Code (Result, "set http GET headers");

      Result := Curl_Easy_Setopt_String (Req.Data, Constants.CURLOPT_URL, Req.URL);
      Check_Code (Result, "set url");

      Result := Curl_Easy_Setopt_String (Req.Data, Constants.CURLOPT_POSTFIELDS, Req.Content);
      Check_Code (Result, "set post data");

      Result := Curl_Easy_Setopt_Long (Req.Data, Constants.CURLOPT_POSTFIELDSIZE, Data'Length);
      Check_Code (Result, "set post data");

      Response := new Curl_Http_Response;
      Result := Curl_Easy_Setopt_Data (Req.Data, Constants.CURLOPT_WRITEDATA, Response);
      Check_Code (Result, "set write data");
      Reply.Delegate := Response.all'Access;

      Result := Curl_Easy_Perform (Req.Data);
      Check_Code (Result, "get request");

      Result := Curl_Easy_Getinfo_Long (Req.Data, Constants.CURLINFO_RESPONSE_CODE, Status'Access);
      Check_Code (Result, "get response code");
      Response.Status := Natural (Status);
   end Do_Post;

   overriding
   procedure Do_Put (Manager  : in Curl_Http_Manager;
                     Http     : in Client'Class;
                     URI      : in String;
                     Data     : in String;
                     Reply    : out Response'Class) is
      pragma Unreferenced (Manager);
      use Interfaces.C;

      Req      : constant Curl_Http_Request_Access := Get_Request (Http);
      Result   : CURL_Code;
      Response : Curl_Http_Response_Access;
      Status   : aliased C.long;
   begin
      Log.Info ("PUT {0}", URI);

      Result := Curl_Easy_Setopt_Write_Callback (Req.Data, Constants.CURLOPT_WRITEUNCTION,
                                                 Read_Response'Access);
      Check_Code (Result, "set callback");
      Req.Set_Headers;

      Interfaces.C.Strings.Free (Req.URL);
      Req.URL := Strings.New_String (URI);

      Interfaces.C.Strings.Free (Req.Content);
      Req.Content := Strings.New_String (Data);

      Result := Curl_Easy_Setopt_Long (Req.Data, Constants.CURLOPT_POST, 1);
      Check_Code (Result, "set http PUT");

      Result := Curl_Easy_Setopt_Long (Req.Data, Constants.CURLOPT_HEADER, 1);
      Check_Code (Result, "set header");

      Result := Curl_Easy_Setopt_String (Req.Data, Constants.CURLOPT_CUSTOMREQUEST, PUT_TOKEN);
      Check_Code (Result, "set http PUT");

      Result := Curl_Easy_Setopt_Slist (Req.Data, Constants.CURLOPT_HTTPHEADER, Req.Curl_Headers);
      Check_Code (Result, "set http GET headers");

      Result := Curl_Easy_Setopt_String (Req.Data, Constants.CURLOPT_URL, Req.URL);
      Check_Code (Result, "set url");

      Result := Curl_Easy_Setopt_String (Req.Data, Constants.CURLOPT_POSTFIELDS, Req.Content);
      Check_Code (Result, "set post data");

      Result := Curl_Easy_Setopt_Long (Req.Data, Constants.CURLOPT_POSTFIELDSIZE, Data'Length);
      Check_Code (Result, "set post data");

      Response := new Curl_Http_Response;
      Result := Curl_Easy_Setopt_Data (Req.Data, Constants.CURLOPT_WRITEDATA, Response);
      Check_Code (Result, "set write data");
      Reply.Delegate := Response.all'Access;

      Result := Curl_Easy_Perform (Req.Data);
      Check_Code (Result, "get request");

      Result := Curl_Easy_Getinfo_Long (Req.Data, Constants.CURLINFO_RESPONSE_CODE, Status'Access);
      Check_Code (Result, "get response code");
      Response.Status := Natural (Status);
   end Do_Put;

   overriding
   procedure Do_Delete (Manager  : in Curl_Http_Manager;
                        Http     : in Client'Class;
                        URI      : in String;
                        Reply    : out Response'Class) is
      pragma Unreferenced (Manager);
      use Interfaces.C;

      Req      : constant Curl_Http_Request_Access := Get_Request (Http);
      Result   : CURL_Code;
      Response : Curl_Http_Response_Access;
      Status   : aliased C.long;
   begin
      Log.Info ("DELETE {0}", URI);

      Result := Curl_Easy_Setopt_Write_Callback (Req.Data, Constants.CURLOPT_WRITEUNCTION,
                                                 Read_Response'Access);
      Check_Code (Result, "set callback");
      Req.Set_Headers;

      Interfaces.C.Strings.Free (Req.URL);
      Req.URL := Strings.New_String (URI);

      Result := Curl_Easy_Setopt_Long (Req.Data, Constants.CURLOPT_POST, 1);
      Check_Code (Result, "set http DELETE");

      Result := Curl_Easy_Setopt_Long (Req.Data, Constants.CURLOPT_HEADER, 1);
      Check_Code (Result, "set header");

      Result := Curl_Easy_Setopt_String (Req.Data, Constants.CURLOPT_CUSTOMREQUEST, DELETE_TOKEN);
      Check_Code (Result, "set http DELETE");

      Result := Curl_Easy_Setopt_Slist (Req.Data, Constants.CURLOPT_HTTPHEADER, Req.Curl_Headers);
      Check_Code (Result, "set http GET headers");

      Result := Curl_Easy_Setopt_String (Req.Data, Constants.CURLOPT_URL, Req.URL);
      Check_Code (Result, "set url");

      Response := new Curl_Http_Response;
      Result := Curl_Easy_Setopt_Data (Req.Data, Constants.CURLOPT_WRITEDATA, Response);
      Check_Code (Result, "set write data");
      Reply.Delegate := Response.all'Access;

      Result := Curl_Easy_Perform (Req.Data);
      Check_Code (Result, "get request");

      Result := Curl_Easy_Getinfo_Long (Req.Data, Constants.CURLINFO_RESPONSE_CODE, Status'Access);
      Check_Code (Result, "get response code");
      Response.Status := Natural (Status);
   end Do_Delete;

   --  ------------------------------
   --  Set the timeout for the connection.
   --  ------------------------------
   overriding
   procedure Set_Timeout (Manager : in Curl_Http_Manager;
                          Http    : in Client'Class;
                          Timeout : in Duration) is
      pragma Unreferenced (Manager);

      Req      : constant Curl_Http_Request_Access := Get_Request (Http);
      Time     : constant Interfaces.C.long := Interfaces.C.long (Timeout);
      Result   : CURL_Code;
   begin
      Result := Curl_Easy_Setopt_Long (Req.Data, Constants.CURLOPT_TIMEOUT, Time);
      Check_Code (Result, "set timeout");
   end Set_Timeout;

   overriding
   procedure Finalize (Request : in out Curl_Http_Request) is
   begin
      if Request.Data /= System.Null_Address then
         Curl_Easy_Cleanup (Request.Data);
         Request.Data := System.Null_Address;
      end if;
      if Request.Curl_Headers /= null then
         Curl_Slist_Free_All (Request.Curl_Headers);
         Request.Curl_Headers := null;
      end if;
      Interfaces.C.Strings.Free (Request.URL);
      Interfaces.C.Strings.Free (Request.Content);
   end Finalize;

   --  ------------------------------
   --  Get the response body as a string.
   --  ------------------------------
   overriding
   function Get_Body (Reply : in Curl_Http_Response) return String is
   begin
      return Ada.Strings.Unbounded.To_String (Reply.Content);
   end Get_Body;

   --  ------------------------------
   --  Get the response status code.
   --  ------------------------------
   overriding
   function Get_Status (Reply : in Curl_Http_Response) return Natural is
   begin
      return Reply.Status;
   end Get_Status;

end Util.Http.Clients.Curl;

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

with Util.Strings;
with Util.Log.Loggers;
with Util.Http.Clients.Curl.Constants;
package body Util.Http.Clients.Curl is

   use System;

   pragma Linker_Options ("-lcurl");

   Log   : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Util.Http.Clients.Curl");

   function Get_Request (Http : in Client'Class) return Curl_Http_Request_Access;

   PUT_TOKEN    : constant Chars_Ptr := Strings.New_String ("PUT");
   DELETE_TOKEN : constant Chars_Ptr := Strings.New_String ("DELETE");
   Manager      : aliased Curl_Http_Manager;

   --  ------------------------------
   --  Register the CURL Http manager.
   --  ------------------------------
   procedure Register is
   begin
      Default_Http_Manager := Manager'Access;
   end Register;

   --  ------------------------------
   --  Check the CURL result code and report and exception and a log message if
   --  the CURL code indicates an error.
   --  ------------------------------
   procedure Check_Code (Code    : in CURL_Code;
                         Message : in String) is
   begin
      if Code /= CURLE_OK then
         declare
            Error : constant Chars_Ptr := Curl_Easy_Strerror (Code);
            Msg   : constant String := Interfaces.C.Strings.Value (Error);
         begin
            Log.Error ("{0}: {1}", Message, Msg);
            raise Connection_Error with Msg;
         end;
      end if;
   end Check_Code;

   --  ------------------------------
   --  Create a new HTTP request associated with the current request manager.
   --  ------------------------------
   procedure Create (Manager  : in Curl_Http_Manager;
                     Http     : in out Client'Class) is
      pragma Unreferenced (Manager);

      Request : Curl_Http_Request_Access;
      Data    : CURL;
   begin
      Data := Curl_Easy_Init;
      if Data = System.Null_Address then
         raise Storage_Error with "curl_easy_init cannot create the CURL instance";
      end if;
      Request := new Curl_Http_Request;
      Request.Data  := Data;
      Http.Delegate := Request.all'Access;
   end Create;

   function Get_Request (Http : in Client'Class) return Curl_Http_Request_Access is
   begin
      return Curl_Http_Request'Class (Http.Delegate.all)'Access;
   end Get_Request;

   --  ------------------------------
   --  This function is called by CURL when a response line was read.
   --  ------------------------------
   function Read_Response (Data     : in Chars_Ptr;
                           Size     : in Size_T;
                           Nmemb    : in Size_T;
                           Response : in Curl_Http_Response_Access) return Size_T is

      Total : constant Size_T := Size * Nmemb;
      Line  : constant String := Interfaces.C.Strings.Value (Data, Total);
   begin
      Log.Info ("RCV: {0}", Line);
      if Response.Parsing_Body then
         Ada.Strings.Unbounded.Append (Response.Content, Line);

      elsif Total = 2 and then Line (1) = ASCII.CR and then Line (2) = ASCII.LF then
         Response.Parsing_Body := True;

      else
         declare
            Pos   : constant Natural := Util.Strings.Index (Line, ':');
            Start : Natural;
            Last  : Natural;
         begin
            if Pos > 0 then
               Start := Pos + 1;
               while Start <= Line'Last and Line (Start) = ' ' loop
                  Start := Start + 1;
               end loop;
               Last := Line'Last;
               while Last >= Start and (Line (Last) = ASCII.CR or Line (Last) = ASCII.LF) loop
                  Last := Last - 1;
               end loop;
               Response.Add_Header (Name  => Line (Line'First .. Pos - 1),
                                    Value => Line (Start .. Last));
            end if;
         end;
      end if;
      return Total;
   end Read_Response;

   --  ------------------------------
   --  Prepare to setup the headers in the request.
   --  ------------------------------
   procedure Set_Headers (Request : in out Curl_Http_Request) is
      procedure Process (Name, Value : in String);

      procedure Process (Name, Value : in String) is
         S : Chars_Ptr := Strings.New_String (Name & ": " & Value);
      begin
         Request.Curl_Headers := Curl_Slist_Append (Request.Curl_Headers, S);
         Interfaces.C.Strings.Free (S);
      end Process;

   begin
      if Request.Curl_Headers /= null then
         Curl_Slist_Free_All (Request.Curl_Headers);
         Request.Curl_Headers := null;
      end if;

      Request.Iterate_Headers (Process'Access);
   end Set_Headers;

   procedure Do_Get (Manager  : in Curl_Http_Manager;
                     Http     : in Client'Class;
                     URI      : in String;
                     Reply    : out Response'Class) is
      pragma Unreferenced (Manager);
      use Interfaces.C;

      Req      : constant Curl_Http_Request_Access := Get_Request (Http);
      Result   : CURL_Code;
      Response : Curl_Http_Response_Access;
      Status   : aliased C.long;
   begin
      Log.Info ("GET {0}", URI);
      Result := Curl_Easy_Setopt_Write_Callback (Req.Data, Constants.CURLOPT_WRITEUNCTION,
                                                 Read_Response'Access);
      Check_Code (Result, "set callback");

      Req.Set_Headers;

      Interfaces.C.Strings.Free (Req.URL);
      Req.URL := Strings.New_String (URI);

      Result := Curl_Easy_Setopt_Long (Req.Data, Constants.CURLOPT_HTTPGET, 1);
      Check_Code (Result, "set http GET");

      Result := Curl_Easy_Setopt_Long (Req.Data, Constants.CURLOPT_HEADER, 1);
      Check_Code (Result, "set header");

      Result := Curl_Easy_Setopt_Slist (Req.Data, Constants.CURLOPT_HTTPHEADER, Req.Curl_Headers);
      Check_Code (Result, "set http GET headers");

      Result := Curl_Easy_Setopt_String (Req.Data, Constants.CURLOPT_URL, Req.URL);
      Check_Code (Result, "set url");

      Response := new Curl_Http_Response;
      Result := Curl_Easy_Setopt_Data (Req.Data, Constants.CURLOPT_WRITEDATA, Response);
      Check_Code (Result, "set write data");
      Reply.Delegate := Response.all'Access;

      Result := Curl_Easy_Perform (Req.Data);
      Check_Code (Result, "get request");

      Result := Curl_Easy_Getinfo_Long (Req.Data, Constants.CURLINFO_RESPONSE_CODE, Status'Access);
      Check_Code (Result, "get response code");
      Response.Status := Natural (Status);
   end Do_Get;

   procedure Do_Post (Manager  : in Curl_Http_Manager;
                      Http     : in Client'Class;
                      URI      : in String;
                      Data     : in String;
                      Reply    : out Response'Class) is
      pragma Unreferenced (Manager);
      use Interfaces.C;

      Req      : constant Curl_Http_Request_Access := Get_Request (Http);
      Result   : CURL_Code;
      Response : Curl_Http_Response_Access;
      Status   : aliased C.long;
   begin
      Log.Info ("POST {0}", URI);

      Result := Curl_Easy_Setopt_Write_Callback (Req.Data, Constants.CURLOPT_WRITEUNCTION,
                                                 Read_Response'Access);
      Check_Code (Result, "set callback");
      Req.Set_Headers;

      Interfaces.C.Strings.Free (Req.URL);
      Req.URL := Strings.New_String (URI);

      Interfaces.C.Strings.Free (Req.Content);
      Req.Content := Strings.New_String (Data);

      Result := Curl_Easy_Setopt_Long (Req.Data, Constants.CURLOPT_POST, 1);
      Check_Code (Result, "set http POST");

      Result := Curl_Easy_Setopt_Long (Req.Data, Constants.CURLOPT_HEADER, 1);
      Check_Code (Result, "set header");

      Result := Curl_Easy_Setopt_Slist (Req.Data, Constants.CURLOPT_HTTPHEADER, Req.Curl_Headers);
      Check_Code (Result, "set http GET headers");

      Result := Curl_Easy_Setopt_String (Req.Data, Constants.CURLOPT_URL, Req.URL);
      Check_Code (Result, "set url");

      Result := Curl_Easy_Setopt_String (Req.Data, Constants.CURLOPT_POSTFIELDS, Req.Content);
      Check_Code (Result, "set post data");

      Result := Curl_Easy_Setopt_Long (Req.Data, Constants.CURLOPT_POSTFIELDSIZE, Data'Length);
      Check_Code (Result, "set post data");

      Response := new Curl_Http_Response;
      Result := Curl_Easy_Setopt_Data (Req.Data, Constants.CURLOPT_WRITEDATA, Response);
      Check_Code (Result, "set write data");
      Reply.Delegate := Response.all'Access;

      Result := Curl_Easy_Perform (Req.Data);
      Check_Code (Result, "get request");

      Result := Curl_Easy_Getinfo_Long (Req.Data, Constants.CURLINFO_RESPONSE_CODE, Status'Access);
      Check_Code (Result, "get response code");
      Response.Status := Natural (Status);
   end Do_Post;

   overriding
   procedure Do_Put (Manager  : in Curl_Http_Manager;
                     Http     : in Client'Class;
                     URI      : in String;
                     Data     : in String;
                     Reply    : out Response'Class) is
      pragma Unreferenced (Manager);
      use Interfaces.C;

      Req      : constant Curl_Http_Request_Access := Get_Request (Http);
      Result   : CURL_Code;
      Response : Curl_Http_Response_Access;
      Status   : aliased C.long;
   begin
      Log.Info ("PUT {0}", URI);

      Result := Curl_Easy_Setopt_Write_Callback (Req.Data, Constants.CURLOPT_WRITEUNCTION,
                                                 Read_Response'Access);
      Check_Code (Result, "set callback");
      Req.Set_Headers;

      Interfaces.C.Strings.Free (Req.URL);
      Req.URL := Strings.New_String (URI);

      Interfaces.C.Strings.Free (Req.Content);
      Req.Content := Strings.New_String (Data);

      Result := Curl_Easy_Setopt_Long (Req.Data, Constants.CURLOPT_POST, 1);
      Check_Code (Result, "set http PUT");

      Result := Curl_Easy_Setopt_Long (Req.Data, Constants.CURLOPT_HEADER, 1);
      Check_Code (Result, "set header");

      Result := Curl_Easy_Setopt_String (Req.Data, Constants.CURLOPT_CUSTOMREQUEST, PUT_TOKEN);
      Check_Code (Result, "set http PUT");

      Result := Curl_Easy_Setopt_Slist (Req.Data, Constants.CURLOPT_HTTPHEADER, Req.Curl_Headers);
      Check_Code (Result, "set http GET headers");

      Result := Curl_Easy_Setopt_String (Req.Data, Constants.CURLOPT_URL, Req.URL);
      Check_Code (Result, "set url");

      Result := Curl_Easy_Setopt_String (Req.Data, Constants.CURLOPT_POSTFIELDS, Req.Content);
      Check_Code (Result, "set post data");

      Result := Curl_Easy_Setopt_Long (Req.Data, Constants.CURLOPT_POSTFIELDSIZE, Data'Length);
      Check_Code (Result, "set post data");

      Response := new Curl_Http_Response;
      Result := Curl_Easy_Setopt_Data (Req.Data, Constants.CURLOPT_WRITEDATA, Response);
      Check_Code (Result, "set write data");
      Reply.Delegate := Response.all'Access;

      Result := Curl_Easy_Perform (Req.Data);
      Check_Code (Result, "get request");

      Result := Curl_Easy_Getinfo_Long (Req.Data, Constants.CURLINFO_RESPONSE_CODE, Status'Access);
      Check_Code (Result, "get response code");
      Response.Status := Natural (Status);
   end Do_Put;

   overriding
   procedure Do_Delete (Manager  : in Curl_Http_Manager;
                        Http     : in Client'Class;
                        URI      : in String;
                        Reply    : out Response'Class) is
      pragma Unreferenced (Manager);
      use Interfaces.C;

      Req      : constant Curl_Http_Request_Access := Get_Request (Http);
      Result   : CURL_Code;
      Response : Curl_Http_Response_Access;
      Status   : aliased C.long;
   begin
      Log.Info ("DELETE {0}", URI);

      Result := Curl_Easy_Setopt_Write_Callback (Req.Data, Constants.CURLOPT_WRITEUNCTION,
                                                 Read_Response'Access);
      Check_Code (Result, "set callback");
      Req.Set_Headers;

      Interfaces.C.Strings.Free (Req.URL);
      Req.URL := Strings.New_String (URI);

      Result := Curl_Easy_Setopt_Long (Req.Data, Constants.CURLOPT_POST, 1);
      Check_Code (Result, "set http DELETE");

      Result := Curl_Easy_Setopt_Long (Req.Data, Constants.CURLOPT_HEADER, 1);
      Check_Code (Result, "set header");

      Result := Curl_Easy_Setopt_String (Req.Data, Constants.CURLOPT_CUSTOMREQUEST, DELETE_TOKEN);
      Check_Code (Result, "set http DELETE");

      Result := Curl_Easy_Setopt_Slist (Req.Data, Constants.CURLOPT_HTTPHEADER, Req.Curl_Headers);
      Check_Code (Result, "set http GET headers");

      Result := Curl_Easy_Setopt_String (Req.Data, Constants.CURLOPT_URL, Req.URL);
      Check_Code (Result, "set url");

      Response := new Curl_Http_Response;
      Result := Curl_Easy_Setopt_Data (Req.Data, Constants.CURLOPT_WRITEDATA, Response);
      Check_Code (Result, "set write data");
      Reply.Delegate := Response.all'Access;

      Result := Curl_Easy_Perform (Req.Data);
      Check_Code (Result, "get request");

      Result := Curl_Easy_Getinfo_Long (Req.Data, Constants.CURLINFO_RESPONSE_CODE, Status'Access);
      Check_Code (Result, "get response code");
      Response.Status := Natural (Status);
   end Do_Delete;

   --  ------------------------------
   --  Set the timeout for the connection.
   --  ------------------------------
   overriding
   procedure Set_Timeout (Manager : in Curl_Http_Manager;
                          Http    : in Client'Class;
                          Timeout : in Duration) is
      pragma Unreferenced (Manager);

      Req      : constant Curl_Http_Request_Access := Get_Request (Http);
      Time     : constant Interfaces.C.long := Interfaces.C.long (Timeout);
      Result   : CURL_Code;
   begin
      Result := Curl_Easy_Setopt_Long (Req.Data, Constants.CURLOPT_TIMEOUT, Time);
      Check_Code (Result, "set timeout");
   end Set_Timeout;

   overriding
   procedure Finalize (Request : in out Curl_Http_Request) is
   begin
      if Request.Data /= System.Null_Address then
         Curl_Easy_Cleanup (Request.Data);
         Request.Data := System.Null_Address;
      end if;
      if Request.Curl_Headers /= null then
         Curl_Slist_Free_All (Request.Curl_Headers);
         Request.Curl_Headers := null;
      end if;
      Interfaces.C.Strings.Free (Request.URL);
      Interfaces.C.Strings.Free (Request.Content);
   end Finalize;

   --  ------------------------------
   --  Get the response body as a string.
   --  ------------------------------
   overriding
   function Get_Body (Reply : in Curl_Http_Response) return String is
   begin
      return Ada.Strings.Unbounded.To_String (Reply.Content);
   end Get_Body;

   --  ------------------------------
   --  Get the response status code.
   --  ------------------------------
   overriding
   function Get_Status (Reply : in Curl_Http_Response) return Natural is
   begin
      return Reply.Status;
   end Get_Status;

end Util.Http.Clients.Curl;

Fix compilation warning

Fix compilation warning


-----------------------------------------------------------------------
--  widgets-factory -- Factory for widget Components
--  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 ASF.Views.Nodes;
with ASF.Components.Base;
with ASF.Components.Widgets.Inputs;

package body ASF.Components.Widgets.Factory is

   use ASF.Components.Base;

   function Create_Input return UIComponent_Access;
   function Create_Complete return UIComponent_Access;

   --  ------------------------------
   --  Create a UIInput component
   --  ------------------------------
   function Create_Input return UIComponent_Access is
   begin
      return new ASF.Components.Widgets.Inputs.UIInput;
   end Create_Input;

   --  ------------------------------
   --  Create a UIComplete component
   --  ------------------------------
   function Create_Complete return UIComponent_Access is
   begin
      return new ASF.Components.Widgets.Inputs.UIComplete;
   end Create_Complete;

   use ASF.Views.Nodes;

   URI              : aliased constant String := "http://code.google.com/p/ada-asf/widget";
   AUTOCOMPLETE_TAG : aliased constant String := "autocomplete";
   INPUT_TEXT_TAG   : aliased constant String := "inputText";

   Widget_Bindings : aliased constant ASF.Factory.Binding_Array
     := (1 => (Name      => AUTOCOMPLETE_TAG'Access,
               Component => Create_Complete'Access,
               Tag       => Create_Component_Node'Access),
         2 => (Name      => INPUT_TEXT_TAG'Access,
               Component => Create_Input'Access,
               Tag       => Create_Component_Node'Access)
        );

   Core_Factory : aliased constant ASF.Factory.Factory_Bindings
     := (URI => URI'Access, Bindings => Widget_Bindings'Access);

   --  ------------------------------
   --  Get the widget component factory.
   --  ------------------------------
   function Definition return ASF.Factory.Factory_Bindings_Access is
   begin
      return Core_Factory'Access;
   end Definition;

end ASF.Components.Widgets.Factory;

-----------------------------------------------------------------------
--  widgets-factory -- Factory for widget Components
--  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 ASF.Views.Nodes;
with ASF.Components.Base;
with ASF.Components.Widgets.Inputs;

package body ASF.Components.Widgets.Factory is

   use ASF.Components.Base;

   function Create_Input return UIComponent_Access;
   function Create_Input_Date return UIComponent_Access;
   function Create_Complete return UIComponent_Access;

   --  ------------------------------
   --  Create a UIInput component
   --  ------------------------------
   function Create_Input return UIComponent_Access is
   begin
      return new ASF.Components.Widgets.Inputs.UIInput;
   end Create_Input;

   --  ------------------------------
   --  Create a UIInput component
   --  ------------------------------
   function Create_Input_Date return UIComponent_Access is
   begin
      return new ASF.Components.Widgets.Inputs.UIInputDate;
   end Create_Input_Date;

   --  ------------------------------
   --  Create a UIComplete component
   --  ------------------------------
   function Create_Complete return UIComponent_Access is
   begin
      return new ASF.Components.Widgets.Inputs.UIComplete;
   end Create_Complete;

   use ASF.Views.Nodes;

   URI              : aliased constant String := "http://code.google.com/p/ada-asf/widget";
   AUTOCOMPLETE_TAG : aliased constant String := "autocomplete";
   INPUT_DATE_TAG   : aliased constant String := "inputDate";
   INPUT_TEXT_TAG   : aliased constant String := "inputText";

   Widget_Bindings : aliased constant ASF.Factory.Binding_Array
     := (1 => (Name      => AUTOCOMPLETE_TAG'Access,
               Component => Create_Complete'Access,
               Tag       => Create_Component_Node'Access),
         2 => (Name      => INPUT_DATE_TAG'Access,
               Component => Create_Input_Date'Access,
               Tag       => Create_Component_Node'Access),
         3 => (Name      => INPUT_TEXT_TAG'Access,
               Component => Create_Input'Access,
               Tag       => Create_Component_Node'Access)
        );

   Core_Factory : aliased constant ASF.Factory.Factory_Bindings
     := (URI => URI'Access, Bindings => Widget_Bindings'Access);

   --  ------------------------------
   --  Get the widget component factory.
   --  ------------------------------
   function Definition return ASF.Factory.Factory_Bindings_Access is
   begin
      return Core_Factory'Access;
   end Definition;

end ASF.Components.Widgets.Factory;

Add the inputDate component in the factory


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

with AUnit.Test_Caller;
with AUnit.Assertions;
with EL.Expressions;
with Test_Bean;
package body EL.Expressions.Tests is

   use Test_Bean;
   use EL.Expressions;
   use AUnit.Assertions;
   use AUnit.Test_Fixtures;

   procedure Check_Error (T    : in out Test'Class;
                          Expr : in String);

   --  Check that evaluating an expression raises an exception
   procedure Check_Error (T    : in out Test'Class;
                          Expr : in String) is
      E : Expression;
   begin
      E := Create_Expression (Context => T.Context, Expr => Expr);

      pragma Unreferenced (E);
      Assert (Condition => False,
              Message => "Evaludation of '" & Expr & "' should raise an exception");
   exception
      when Invalid_Expression =>
         null;
   end Check_Error;

   --  Check that evaluating an expression returns the expected result
   --  (to keep the test simple, results are only checked using strings)
   procedure Check (T      : in out Test;
                    Expr   : in String;
                    Expect : in String) is
      E : constant Expression := Create_Expression (Context => T.Context,
                                                    Expr => Expr);
      V : constant Object := E.Get_Value (Context => T.Context);
   begin
      Assert (Condition => To_String (V) = Expect,
              Message => "Evaluate '" & Expr & "' returned '" & To_String (V)
              & "' when we expect '" & Expect & "'");
   end Check;

   --  Test evaluation of expression using a bean
   procedure Test_Bean_Evaluation (T : in out Test) is
      P : constant Person_Access := Create_Person ("Joe", "Black", 42);
   begin
      T.Context.Set_Variable ("user", P);

      Check (T, "#{user.firstName}", "Joe");
      Check (T, "#{user.lastName}", "Black");
      Check (T, "#{user.age}", " 42");
      Check (T, "#{user.date}", To_String (To_Object (P.Date)));
      Check (T, "#{user.weight}", To_String (To_Object (P.Weight)));

      P.Age := P.Age + 1;
      Check (T, "#{user.age}", " 43");
      Check (T, "#{user.firstName & ' ' & user.lastName}", "Joe Black");

      Check (T, "Joe is#{user.age} year#{user.age > 0 ? 's' : ''} old",
             "Joe is 43 years old");
   end Test_Bean_Evaluation;

   --  Test evaluation of expression using a bean
   procedure Test_Parse_Error (T : in out Test) is
   begin
      Check_Error (T, "#{1 +}");
      Check_Error (T, "#{12(}");
      Check_Error (T, "#{foo(1)}");
      Check_Error (T, "#{1+2+'abc}");
      Check_Error (T, "#{1+""}");
      Check_Error (T, "#{12");
      Check_Error (T, "${1");
      Check_Error (T, "test #{'}");
   end Test_Parse_Error;

   package Caller is new AUnit.Test_Caller (Test);

   procedure Add_Tests (Suite : AUnit.Test_Suites.Access_Test_Suite) is
   begin
      --  Test_Bean verifies several methods.  Register several times
      --  to enumerate what is tested.
      Suite.Add_Test (Caller.Create ("Test EL.Contexts.Set_Variable",
                                     Test_Bean_Evaluation'Access));
      Suite.Add_Test (Caller.Create ("Test EL.Beans.Get_Value",
                                     Test_Bean_Evaluation'Access));
      Suite.Add_Test (Caller.Create ("Test EL.Expressions.Create_Expression",
                                     Test_Bean_Evaluation'Access));
      Suite.Add_Test (Caller.Create ("Test EL.Expressions.Get_Value",
                                     Test_Bean_Evaluation'Access));
      Suite.Add_Test (Caller.Create ("Test EL.Expressions.Create_Expression (Parse Error)",
                                     Test_Parse_Error'Access));

   end Add_Tests;

end EL.Expressions.Tests;

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

with AUnit.Test_Caller;
with AUnit.Assertions;
with EL.Expressions;
with Test_Bean;
package body EL.Expressions.Tests is

   use Test_Bean;
   use EL.Expressions;
   use AUnit.Assertions;
   use AUnit.Test_Fixtures;

   procedure Check_Error (T    : in out Test'Class;
                          Expr : in String);

   --  Check that evaluating an expression raises an exception
   procedure Check_Error (T    : in out Test'Class;
                          Expr : in String) is
      E : Expression;
   begin
      E := Create_Expression (Context => T.Context, Expr => Expr);

      pragma Unreferenced (E);
      Assert (Condition => False,
              Message => "Evaludation of '" & Expr & "' should raise an exception");
   exception
      when Invalid_Expression =>
         null;
   end Check_Error;

   --  Check that evaluating an expression returns the expected result
   --  (to keep the test simple, results are only checked using strings)
   procedure Check (T      : in out Test;
                    Expr   : in String;
                    Expect : in String) is
      E : constant Expression := Create_Expression (Context => T.Context,
                                                    Expr => Expr);
      V : constant Object := E.Get_Value (Context => T.Context);
   begin
      Assert (Condition => To_String (V) = Expect,
              Message => "Evaluate '" & Expr & "' returned '" & To_String (V)
              & "' when we expect '" & Expect & "'");

      declare
         E2 : constant Expression := E.Reduce_Expression (Context => T.Context);
         V2 : constant Object := E2.Get_Value (Context => T.Context);
      begin
         Assert (To_String (V2) = Expect,
                 "Reduce produced incorrect result: " & To_String (V2));
      end;

   end Check;

   --  Test evaluation of expression using a bean
   procedure Test_Bean_Evaluation (T : in out Test) is
      P : constant Person_Access := Create_Person ("Joe", "Black", 42);
   begin
      T.Context.Set_Variable ("user", P);

      Check (T, "#{user.firstName}", "Joe");
      Check (T, "#{user.lastName}", "Black");
      Check (T, "#{user.age}", " 42");
      Check (T, "#{user.date}", To_String (To_Object (P.Date)));
      Check (T, "#{user.weight}", To_String (To_Object (P.Weight)));

      P.Age := P.Age + 1;
      Check (T, "#{user.age}", " 43");
      Check (T, "#{user.firstName & ' ' & user.lastName}", "Joe Black");

      Check (T, "Joe is#{user.age} year#{user.age > 0 ? 's' : ''} old",
             "Joe is 43 years old");
   end Test_Bean_Evaluation;

   --  Test evaluation of expression using a bean
   procedure Test_Parse_Error (T : in out Test) is
   begin
      Check_Error (T, "#{1 +}");
      Check_Error (T, "#{12(}");
      Check_Error (T, "#{foo(1)}");
      Check_Error (T, "#{1+2+'abc}");
      Check_Error (T, "#{1+""}");
      Check_Error (T, "#{12");
      Check_Error (T, "${1");
      Check_Error (T, "test #{'}");
   end Test_Parse_Error;

   package Caller is new AUnit.Test_Caller (Test);

   procedure Add_Tests (Suite : AUnit.Test_Suites.Access_Test_Suite) is
   begin
      --  Test_Bean verifies several methods.  Register several times
      --  to enumerate what is tested.
      Suite.Add_Test (Caller.Create ("Test EL.Contexts.Set_Variable",
                                     Test_Bean_Evaluation'Access));
      Suite.Add_Test (Caller.Create ("Test EL.Beans.Get_Value",
                                     Test_Bean_Evaluation'Access));
      Suite.Add_Test (Caller.Create ("Test EL.Expressions.Create_Expression",
                                     Test_Bean_Evaluation'Access));
      Suite.Add_Test (Caller.Create ("Test EL.Expressions.Get_Value",
                                     Test_Bean_Evaluation'Access));
      Suite.Add_Test (Caller.Create ("Test EL.Expressions.Create_Expression (Parse Error)",
                                     Test_Parse_Error'Access));

   end Add_Tests;

end EL.Expressions.Tests;

Add unit test for Reduce_Expression

Add unit test for Reduce_Expression


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

with Ada.Strings.Hash;
with Ada.Strings.Wide_Wide_Hash;
with Ada.Unchecked_Conversion;
with Interfaces;
with Util.Beans.Basic;
function Util.Beans.Objects.Hash (Key : in Object) return Ada.Containers.Hash_Type is
   use Ada.Containers;
   use Ada.Strings;
   use Interfaces;
   use Util.Beans.Basic;

   type Unsigned_32_Array is array (Natural range <>) of Unsigned_32;

   subtype U32_For_Float is Unsigned_32_Array (1 .. Long_Long_Float'Size / 32);

   subtype U32_For_Duration is Unsigned_32_Array (1 .. Duration'Size / 32);

   subtype U32_For_Long is Unsigned_32_Array (1 .. Long_Long_Integer'Size / 32);

   subtype U32_For_Access is Unsigned_32_Array (1 .. Readonly_Bean_Access'Size / 32);

   --  Hash the integer and floats using 32-bit values.
   function To_U32_For_Long is new Ada.Unchecked_Conversion (Source => Long_Long_Integer,
                                                             Target => U32_For_Long);

   --  Likewise for floats.
   function To_U32_For_Float is new Ada.Unchecked_Conversion (Source => Long_Long_Float,
                                                              Target => U32_For_Float);

   --  Likewise for duration.
   function To_U32_For_Duration is new Ada.Unchecked_Conversion (Source => Duration,
                                                                 Target => U32_For_Duration);

   --  Likewise for the bean pointer
   function To_U32_For_Access is new Ada.Unchecked_Conversion (Source => Readonly_Bean_Access,
                                                               Target => U32_For_Access);

begin
   case Key.V.Of_Type is
      when TYPE_NULL =>
         return 0;

      when TYPE_BOOLEAN =>
         if Key.V.Bool_Value then
            return 1;
         else
            return 2;
         end if;

      when TYPE_INTEGER =>
         declare
            U32 : constant U32_For_Long :=  To_U32_For_Long (Key.V.Int_Value);
            Val : Unsigned_32 := U32 (U32'First);
         begin
            for I in U32'First + 1 .. U32'Last loop
               Val := Val xor U32 (I);
            end loop;
            return Hash_Type (Val);
         end;

      when TYPE_FLOAT =>
         declare
            U32 : constant U32_For_Float :=  To_U32_For_Float (Key.V.Float_Value);
            Val : Unsigned_32 := U32 (U32'First);
         begin
            for I in U32'First + 1 .. U32'Last loop
               Val := Val xor U32 (I);
            end loop;
            return Hash_Type (Val);
         end;

      when TYPE_STRING =>
         if Key.V.String_Proxy = null then
            return 0;
         else
            return Hash (Key.V.String_Proxy.Value);
         end if;

      when TYPE_TIME =>
         declare
            U32 : constant U32_For_Duration :=  To_U32_For_Duration (Key.V.Time_Value);
            Val : Unsigned_32 := U32 (U32'First);
         begin
            for I in U32'First + 1 .. U32'Last loop
               Val := Val xor U32 (I);
            end loop;
            return Hash_Type (Val);
         end;

      when TYPE_WIDE_STRING =>
         if Key.V.Wide_Proxy = null then
            return 0;
         else
            return Wide_Wide_Hash (Key.V.Wide_Proxy.Value);
         end if;

      when TYPE_BEAN =>
         if Key.V.Proxy = null or else Bean_Proxy (Key.V.Proxy.all).Bean = null then
            return 0;
         end if;
         declare
            U32 : constant U32_For_Access
              :=  To_U32_For_Access (Bean_Proxy (Key.V.Proxy.all).Bean.all'Access);
            Val : Unsigned_32 := U32 (U32'First);

            --  The loop is not executed if pointers are 32-bit wide.
            pragma Warnings (Off);
         begin
            for I in U32'First + 1 .. U32'Last loop
               Val := Val xor U32 (I);
            end loop;
            return Hash_Type (Val);
         end;

      when TYPE_ARRAY =>
         declare
            Result : Unsigned_32 := 0;
         begin
            for Object of Key.V.Array_Proxy.Values loop
               Result := Result xor Unsigned_32 (Hash (Object));
            end loop;
            return Hash_Type (Result);
         end;

   end case;
end Util.Beans.Objects.Hash;

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

with Ada.Strings.Hash;
with Ada.Strings.Wide_Wide_Hash;
with Ada.Unchecked_Conversion;
with Interfaces;
with Util.Beans.Basic;
function Util.Beans.Objects.Hash (Key : in Object) return Ada.Containers.Hash_Type is
   use Ada.Containers;
   use Ada.Strings;
   use Interfaces;
   use Util.Beans.Basic;

   type Unsigned_32_Array is array (Natural range <>) of Unsigned_32;

   subtype U32_For_Float is Unsigned_32_Array (1 .. Long_Long_Float'Size / 32);

   subtype U32_For_Duration is Unsigned_32_Array (1 .. Duration'Size / 32);

   subtype U32_For_Long is Unsigned_32_Array (1 .. Long_Long_Integer'Size / 32);

   subtype U32_For_Access is Unsigned_32_Array (1 .. Readonly_Bean_Access'Size / 32);

   --  Hash the integer and floats using 32-bit values.
   function To_U32_For_Long is new Ada.Unchecked_Conversion (Source => Long_Long_Integer,
                                                             Target => U32_For_Long);

   --  Likewise for floats.
   function To_U32_For_Float is new Ada.Unchecked_Conversion (Source => Long_Long_Float,
                                                              Target => U32_For_Float);

   --  Likewise for duration.
   function To_U32_For_Duration is new Ada.Unchecked_Conversion (Source => Duration,
                                                                 Target => U32_For_Duration);

   --  Likewise for the bean pointer
   function To_U32_For_Access is new Ada.Unchecked_Conversion (Source => Readonly_Bean_Access,
                                                               Target => U32_For_Access);

begin
   case Key.V.Of_Type is
      when TYPE_NULL =>
         return 0;

      when TYPE_BOOLEAN =>
         if Key.V.Bool_Value then
            return 1;
         else
            return 2;
         end if;

      when TYPE_INTEGER =>
         declare
            U32 : constant U32_For_Long :=  To_U32_For_Long (Key.V.Int_Value);
            Val : Unsigned_32 := U32 (U32'First);
         begin
            for I in U32'First + 1 .. U32'Last loop
               Val := Val xor U32 (I);
            end loop;
            return Hash_Type (Val);
         end;

      when TYPE_FLOAT =>
         declare
            U32 : constant U32_For_Float :=  To_U32_For_Float (Key.V.Float_Value);
            Val : Unsigned_32 := U32 (U32'First);
         begin
            for I in U32'First + 1 .. U32'Last loop
               Val := Val xor U32 (I);
            end loop;
            return Hash_Type (Val);
         end;

      when TYPE_STRING =>
         if Key.V.String_Proxy = null then
            return 0;
         else
            return Hash (Key.V.String_Proxy.Value);
         end if;

      when TYPE_TIME =>
         declare
            U32 : constant U32_For_Duration :=  To_U32_For_Duration (Key.V.Time_Value);
            Val : Unsigned_32 := U32 (U32'First);
         begin
            for I in U32'First + 1 .. U32'Last loop
               Val := Val xor U32 (I);
            end loop;
            return Hash_Type (Val);
         end;

      when TYPE_WIDE_STRING =>
         if Key.V.Wide_Proxy = null then
            return 0;
         else
            return Wide_Wide_Hash (Key.V.Wide_Proxy.Value);
         end if;

      when TYPE_BEAN =>
         if Key.V.Proxy = null or else Bean_Proxy (Key.V.Proxy.all).Bean = null then
            return 0;
         end if;
         declare
            U32 : constant U32_For_Access
              :=  To_U32_For_Access (Bean_Proxy (Key.V.Proxy.all).Bean.all'Access);
            Val : Unsigned_32 := U32 (U32'First);

            --  The loop is not executed if pointers are 32-bit wide.
            pragma Warnings (Off);
         begin
            for I in U32'First + 1 .. U32'Last loop
               Val := Val xor U32 (I);
            end loop;
            return Hash_Type (Val);
         end;

      when TYPE_RECORD =>
         return 0;

      when TYPE_ARRAY =>
         declare
            Result : Unsigned_32 := 0;
         begin
            for Object of Key.V.Array_Proxy.Values loop
               Result := Result xor Unsigned_32 (Hash (Object));
            end loop;
            return Hash_Type (Result);
         end;

   end case;
end Util.Beans.Objects.Hash;

Update to handle the TYPE_RECORD

Update to handle the TYPE_RECORD


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

with MAT.Types;
with MAT.Frames;

with Interfaces;
package MAT.Memory is

   type Allocation is record
      Size   : MAT.Types.Target_Size;
      Frame  : Frames.Frame_Type;
      Time   : MAT.Types.Target_Tick_Ref;
      Thread : MAT.Types.Target_Thread_Ref;
   end record;

   --  Statistics about memory allocation.
   type Memory_Info is record
      Total_Size    : MAT.Types.Target_Size := 0;
      Alloc_Count   : Natural := 0;
      Min_Slot_Size : MAT.Types.Target_Size := 0;
      Max_Slot_Size : MAT.Types.Target_Size := 0;
      Min_Addr      : MAT.Types.Target_Addr := 0;
      Max_Addr      : MAT.Types.Target_Addr := 0;
   end record;

   --  Description of a memory region.
   type Region_Info is record
      Start_Addr : MAT.Types.Target_Addr := 0;
      End_Addr   : MAT.Types.Target_Addr := 0;
      Size       : MAT.Types.Target_Size := 0;
      Path       : Ada.Strings.Unbounded.Unbounded_String;
   end record;

   use type MAT.Types.Target_Addr;
   package Allocation_Maps is
     new Ada.Containers.Ordered_Maps (Key_Type     => MAT.Types.Target_Addr,
                                      Element_Type => Allocation);

   subtype Allocation_Map is Allocation_Maps.Map;
   subtype Allocation_Cursor is Allocation_Maps.Cursor;

   --  Define a map of <tt>Memory_Info</tt> keyed by the thread Id.
   --  Such map allows to give the list of threads and a summary of their allocation.
   use type MAT.Types.Target_Thread_Ref;
   package Memory_Info_Maps is
     new Ada.Containers.Ordered_Maps (Key_Type     => MAT.Types.Target_Thread_Ref,
                                      Element_Type => Memory_Info);

   subtype Memory_Info_Map is Memory_Info_Maps.Map;
   subtype Memory_Info_Cursor is Memory_Info_Maps.Cursor;

   type Frame_Info is record
      Thread : MAT.Types.Target_Thread_Ref;
      Memory : Memory_Info;
   end record;

   --  Define a map of <tt>Frame_Info</tt> keyed by the backtrace function address
   --  that performed the memory allocation directly or indirectly.
   package Frame_Info_Maps is
     new Ada.Containers.Ordered_Maps (Key_Type     => MAT.Types.Target_Addr,
                                      Element_Type => Frame_Info);

   subtype Frame_Info_Map is Frame_Info_Maps.Map;
   subtype Frame_Info_Cursor is Frame_Info_Maps.Cursor;

   package Region_Info_Maps is
     new Ada.Containers.Ordered_Maps (Key_Type     => MAT.Types.Target_Addr,
                                      Element_TYpe => Region_Info);

   subtype Region_Info_Map is Region_Info_Maps.Map;
   subtype Region_Info_Cursor is Region_Info_Maps.Cursor;

private

end MAT.Memory;

-----------------------------------------------------------------------
--  Memory - Memory slot
--  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 Ada.Containers.Ordered_Maps;
with Ada.Strings.Unbounded;

with ELF;
with MAT.Types;
with MAT.Frames;

with Interfaces;
package MAT.Memory is

   type Allocation is record
      Size   : MAT.Types.Target_Size;
      Frame  : Frames.Frame_Type;
      Time   : MAT.Types.Target_Tick_Ref;
      Thread : MAT.Types.Target_Thread_Ref;
   end record;

   --  Statistics about memory allocation.
   type Memory_Info is record
      Total_Size    : MAT.Types.Target_Size := 0;
      Alloc_Count   : Natural := 0;
      Min_Slot_Size : MAT.Types.Target_Size := 0;
      Max_Slot_Size : MAT.Types.Target_Size := 0;
      Min_Addr      : MAT.Types.Target_Addr := 0;
      Max_Addr      : MAT.Types.Target_Addr := 0;
   end record;

   --  Description of a memory region.
   type Region_Info is record
      Start_Addr : MAT.Types.Target_Addr := 0;
      End_Addr   : MAT.Types.Target_Addr := 0;
      Size       : MAT.Types.Target_Size := 0;
      Flags      : ELF.Elf32_Word := 0;
      Path       : Ada.Strings.Unbounded.Unbounded_String;
   end record;

   use type MAT.Types.Target_Addr;
   package Allocation_Maps is
     new Ada.Containers.Ordered_Maps (Key_Type     => MAT.Types.Target_Addr,
                                      Element_Type => Allocation);

   subtype Allocation_Map is Allocation_Maps.Map;
   subtype Allocation_Cursor is Allocation_Maps.Cursor;

   --  Define a map of <tt>Memory_Info</tt> keyed by the thread Id.
   --  Such map allows to give the list of threads and a summary of their allocation.
   use type MAT.Types.Target_Thread_Ref;
   package Memory_Info_Maps is
     new Ada.Containers.Ordered_Maps (Key_Type     => MAT.Types.Target_Thread_Ref,
                                      Element_Type => Memory_Info);

   subtype Memory_Info_Map is Memory_Info_Maps.Map;
   subtype Memory_Info_Cursor is Memory_Info_Maps.Cursor;

   type Frame_Info is record
      Thread : MAT.Types.Target_Thread_Ref;
      Memory : Memory_Info;
   end record;

   --  Define a map of <tt>Frame_Info</tt> keyed by the backtrace function address
   --  that performed the memory allocation directly or indirectly.
   package Frame_Info_Maps is
     new Ada.Containers.Ordered_Maps (Key_Type     => MAT.Types.Target_Addr,
                                      Element_Type => Frame_Info);

   subtype Frame_Info_Map is Frame_Info_Maps.Map;
   subtype Frame_Info_Cursor is Frame_Info_Maps.Cursor;

   package Region_Info_Maps is
     new Ada.Containers.Ordered_Maps (Key_Type     => MAT.Types.Target_Addr,
                                      Element_TYpe => Region_Info);

   subtype Region_Info_Map is Region_Info_Maps.Map;
   subtype Region_Info_Cursor is Region_Info_Maps.Cursor;

private

end MAT.Memory;

Store the elf p_flags information in each region