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

--  GCC 6.0 only (skip Container_Checks until identified need arises)
pragma Suppress (Tampering_Check);

with Ada.Text_IO;
with Ada.Calendar;
with Ada.Containers.Hashed_Maps;
with Ada.Containers.Ordered_Sets;
with Ada.Containers.Vectors;
with Ada.Characters.Latin_1;
with Ada.Directories;
with Ada.Exceptions;

with JohnnyText;
with Parameters;
with Definitions;  use Definitions;

private with Replicant.Platform;

package PortScan is

   package JT  renames JohnnyText;
   package AC  renames Ada.Containers;
   package CAL renames Ada.Calendar;
   package AD  renames Ada.Directories;
   package EX  renames Ada.Exceptions;
   package TIO renames Ada.Text_IO;
   package LAT renames Ada.Characters.Latin_1;
   package PM  renames Parameters;

   type count_type is (total, success, failure, ignored, skipped);
   type dim_handlers is array (count_type) of TIO.File_Type;

   type port_id   is private;
   port_match_failed : constant port_id;

   --  Scan the entire ports tree in order with a single, non-recursive pass
   --  Return True on success
   function scan_entire_ports_tree (portsdir : String) return Boolean;

   --  Starting with a single port, recurse to determine a limited but complete
   --  dependency tree.  Repeated calls will augment already existing data.
   --  Return True on success
   function scan_single_port (catport : String; always_build : Boolean;
                              fatal : out Boolean)
                              return Boolean;

   --  This procedure causes the reverse dependencies to be calculated, and
   --  then the extended (recursive) reverse dependencies.  The former is
   --  used progressively to determine when a port is free to build and the
   --  latter sets the build priority.
   procedure set_build_priority;

   --  Wipe out all scan data so new scan can be performed
   procedure reset_ports_tree;

   --  Returns the number of cores.  The set_cores procedure must be run first.
   --  set_cores was private previously, but we need the information to set
   --  intelligent defaults for the configuration file.
   procedure set_cores;
   function cores_available return cpu_range;

   --  Return " (port deleted)" if the catport doesn't exist
   --  Return " (directory empty)" if the directory exists but has no contents
   --  Return " (Makefile missing)" when makefile is missing
   --  otherwise return blank string
   function obvious_problem (portsdir, catport : String) return String;

private

   package REP  renames Replicant;
   package PLAT renames Replicant.Platform;

   max_ports  : constant := 32000;
   scan_slave : constant builders := 9;
   ss_base    : constant String := "/SL09";
   dir_ports  : constant String := "/xports";
   chroot     : constant String := "/usr/sbin/chroot ";

   type port_id   is range -1 .. max_ports - 1;
   subtype port_index is port_id range 0 .. port_id'Last;

   port_match_failed : constant port_id := port_id'First;

   --  skip "package" because every port has same dependency on ports-mgmt/pkg
   --  except for pkg itself.  Skip "test" because these dependencies are
   --  not required to build packages.
   type dependency_type is (fetch, extract, patch, build, library, runtime);
   subtype LR_set is dependency_type range library .. runtime;

   bmake_execution  : exception;
   pkgng_execution  : exception;
   make_garbage     : exception;
   nonexistent_port : exception;
   circular_logic   : exception;
   seek_failure     : exception;
   unknown_format   : exception;

   package subqueue is new AC.Vectors
     (Element_Type => port_index,
      Index_Type   => port_index);

   package string_crate is new AC.Vectors
     (Element_Type => JT.Text,
      Index_Type   => port_index,
      "="          => JT.SU."=");

   type queue_record is
      record
         ap_index      : port_index;
         reverse_score : port_index;
      end record;

   --  Functions for ranking_crate definitions
   function "<" (L, R : queue_record) return Boolean;

   package ranking_crate is new AC.Ordered_Sets  (Element_Type => queue_record);

   --  Functions for portkey_crate and package_crate definitions
   function port_hash (key : JT.Text) return AC.Hash_Type;

   package portkey_crate is new AC.Hashed_Maps
     (Key_Type        => JT.Text,
      Element_Type    => port_index,
      Hash            => port_hash,
      Equivalent_Keys => JT.equivalent);

   package package_crate is new AC.Hashed_Maps
     (Key_Type        => JT.Text,
      Element_Type    => Boolean,
      Hash            => port_hash,
      Equivalent_Keys => JT.equivalent);

   --  Functions for block_crate definitions
   function block_hash (key : port_index) return AC.Hash_Type;
   function block_ekey (left, right : port_index) return Boolean;

   package block_crate is new AC.Hashed_Maps
     (Key_Type        => port_index,
      Element_Type    => port_index,
      Hash            => block_hash,
      Equivalent_Keys => block_ekey);

   type port_record is
      record
         sequence_id   : port_index           := 0;
         key_cursor    : portkey_crate.Cursor := portkey_crate.No_Element;
         jobs          : builders             := 1;
         ignore_reason : JT.Text              := JT.blank;
         port_version  : JT.Text              := JT.blank;
         package_name  : JT.Text              := JT.blank;
         pkg_dep_query : JT.Text              := JT.blank;
         ignored       : Boolean              := False;
         scanned       : Boolean              := False;
         rev_scanned   : Boolean              := False;
         unlist_failed : Boolean              := False;
         work_locked   : Boolean              := False;
         scan_locked   : Boolean              := False;
         pkg_present   : Boolean              := False;
         remote_pkg    : Boolean              := False;
         never_remote  : Boolean              := False;
         deletion_due  : Boolean              := False;
         use_procfs    : Boolean              := False;
         use_linprocfs : Boolean              := False;
         reverse_score : port_index           := 0;
         min_librun    : Natural              := 0;
         librun        : block_crate.Map;
         blocked_by    : block_crate.Map;
         blocks        : block_crate.Map;
         all_reverse   : block_crate.Map;
         options       : package_crate.Map;
      end record;
   type port_record_access is access all port_record;

   type dim_make_queue is array (scanners) of subqueue.Vector;
   type dim_progress   is array (scanners) of port_index;
   type dim_all_ports  is array (port_index) of aliased port_record;

   all_ports    : dim_all_ports;
   ports_keys   : portkey_crate.Map;
   portlist     : portkey_crate.Map;
   make_queue   : dim_make_queue;
   mq_progress  : dim_progress := (others => 0);
   rank_queue   : ranking_crate.Set;
   number_cores : cpu_range  := cpu_range'First;
   lot_number   : scanners   := 1;
   lot_counter  : port_index := 0;
   last_port    : port_index := 0;
   prescanned   : Boolean    := False;

   procedure iterate_reverse_deps;
   procedure iterate_drill_down;
   procedure populate_set_depends (target  : port_index;
                                   catport : String;
                                   line    : JT.Text;
                                   dtype   : dependency_type);
   procedure populate_set_options (target  : port_index;
                                   line    : JT.Text;
                                   on      : Boolean);
   procedure populate_port_data   (target : port_index);
   procedure populate_port_data_fpc (target : port_index);
   procedure populate_port_data_nps (target : port_index);
   procedure drill_down (next_target     : port_index;
                         original_target : port_index);

   --  subroutines for populate_port_data
   procedure prescan_ports_tree (portsdir : String);
   procedure grep_Makefile (portsdir, category : String);
   procedure walk_all_subdirectories (portsdir, category : String);
   procedure wipe_make_queue;
   procedure parallel_deep_scan (success : out Boolean;
                                 show_progress : Boolean);

   --  some helper routines
   function find_colon (Source : String) return Natural;
   function scrub_phase (Source : String) return JT.Text;
   function get_catport (PR : port_record) return String;
   function scan_progress return String;
   function get_max_lots return scanners;
   function get_pkg_name (origin : String) return String;
   function timestamp (hack : CAL.Time; www_format : Boolean := False) return String;
   function clean_up_pkgsrc_ignore_reason (dirty_string : String) return JT.Text;

   type dim_counters is array (count_type) of Natural;

   --  bulk run variables
   Flog        : dim_handlers;
   start_time  : CAL.Time;
   stop_time   : CAL.Time;
   scan_start  : CAL.Time;
   scan_stop   : CAL.Time;
   bld_counter : dim_counters := (0, 0, 0, 0, 0);

end PortScan;

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

--  GCC 6.0 only (skip Container_Checks until identified need arises)
pragma Suppress (Tampering_Check);

with Ada.Text_IO;
with Ada.Calendar;
with Ada.Containers.Hashed_Maps;
with Ada.Containers.Ordered_Sets;
with Ada.Containers.Vectors;
with Ada.Characters.Latin_1;
with Ada.Directories;
with Ada.Exceptions;

with JohnnyText;
with Parameters;
with Definitions;  use Definitions;

private with Replicant.Platform;

package PortScan is

   package JT  renames JohnnyText;
   package AC  renames Ada.Containers;
   package CAL renames Ada.Calendar;
   package AD  renames Ada.Directories;
   package EX  renames Ada.Exceptions;
   package TIO renames Ada.Text_IO;
   package LAT renames Ada.Characters.Latin_1;
   package PM  renames Parameters;

   type count_type is (total, success, failure, ignored, skipped);
   type dim_handlers is array (count_type) of TIO.File_Type;

   type port_id   is private;
   port_match_failed : constant port_id;

   --  Scan the entire ports tree in order with a single, non-recursive pass
   --  Return True on success
   function scan_entire_ports_tree (portsdir : String) return Boolean;

   --  Starting with a single port, recurse to determine a limited but complete
   --  dependency tree.  Repeated calls will augment already existing data.
   --  Return True on success
   function scan_single_port (catport : String; always_build : Boolean;
                              fatal : out Boolean)
                              return Boolean;

   --  This procedure causes the reverse dependencies to be calculated, and
   --  then the extended (recursive) reverse dependencies.  The former is
   --  used progressively to determine when a port is free to build and the
   --  latter sets the build priority.
   procedure set_build_priority;

   --  Wipe out all scan data so new scan can be performed
   procedure reset_ports_tree;

   --  Returns the number of cores.  The set_cores procedure must be run first.
   --  set_cores was private previously, but we need the information to set
   --  intelligent defaults for the configuration file.
   procedure set_cores;
   function cores_available return cpu_range;

   --  Return " (port deleted)" if the catport doesn't exist
   --  Return " (directory empty)" if the directory exists but has no contents
   --  Return " (Makefile missing)" when makefile is missing
   --  otherwise return blank string
   function obvious_problem (portsdir, catport : String) return String;

private

   package REP  renames Replicant;
   package PLAT renames Replicant.Platform;

   max_ports  : constant := 40000;
   scan_slave : constant builders := 9;
   ss_base    : constant String := "/SL09";
   dir_ports  : constant String := "/xports";
   chroot     : constant String := "/usr/sbin/chroot ";

   type port_id   is range -1 .. max_ports - 1;
   subtype port_index is port_id range 0 .. port_id'Last;

   port_match_failed : constant port_id := port_id'First;

   --  skip "package" because every port has same dependency on ports-mgmt/pkg
   --  except for pkg itself.  Skip "test" because these dependencies are
   --  not required to build packages.
   type dependency_type is (fetch, extract, patch, build, library, runtime);
   subtype LR_set is dependency_type range library .. runtime;

   bmake_execution  : exception;
   pkgng_execution  : exception;
   make_garbage     : exception;
   nonexistent_port : exception;
   circular_logic   : exception;
   seek_failure     : exception;
   unknown_format   : exception;

   package subqueue is new AC.Vectors
     (Element_Type => port_index,
      Index_Type   => port_index);

   package string_crate is new AC.Vectors
     (Element_Type => JT.Text,
      Index_Type   => port_index,
      "="          => JT.SU."=");

   type queue_record is
      record
         ap_index      : port_index;
         reverse_score : port_index;
      end record;

   --  Functions for ranking_crate definitions
   function "<" (L, R : queue_record) return Boolean;

   package ranking_crate is new AC.Ordered_Sets  (Element_Type => queue_record);

   --  Functions for portkey_crate and package_crate definitions
   function port_hash (key : JT.Text) return AC.Hash_Type;

   package portkey_crate is new AC.Hashed_Maps
     (Key_Type        => JT.Text,
      Element_Type    => port_index,
      Hash            => port_hash,
      Equivalent_Keys => JT.equivalent);

   package package_crate is new AC.Hashed_Maps
     (Key_Type        => JT.Text,
      Element_Type    => Boolean,
      Hash            => port_hash,
      Equivalent_Keys => JT.equivalent);

   --  Functions for block_crate definitions
   function block_hash (key : port_index) return AC.Hash_Type;
   function block_ekey (left, right : port_index) return Boolean;

   package block_crate is new AC.Hashed_Maps
     (Key_Type        => port_index,
      Element_Type    => port_index,
      Hash            => block_hash,
      Equivalent_Keys => block_ekey);

   type port_record is
      record
         sequence_id   : port_index           := 0;
         key_cursor    : portkey_crate.Cursor := portkey_crate.No_Element;
         jobs          : builders             := 1;
         ignore_reason : JT.Text              := JT.blank;
         port_version  : JT.Text              := JT.blank;
         package_name  : JT.Text              := JT.blank;
         pkg_dep_query : JT.Text              := JT.blank;
         ignored       : Boolean              := False;
         scanned       : Boolean              := False;
         rev_scanned   : Boolean              := False;
         unlist_failed : Boolean              := False;
         work_locked   : Boolean              := False;
         scan_locked   : Boolean              := False;
         pkg_present   : Boolean              := False;
         remote_pkg    : Boolean              := False;
         never_remote  : Boolean              := False;
         deletion_due  : Boolean              := False;
         use_procfs    : Boolean              := False;
         use_linprocfs : Boolean              := False;
         reverse_score : port_index           := 0;
         min_librun    : Natural              := 0;
         librun        : block_crate.Map;
         blocked_by    : block_crate.Map;
         blocks        : block_crate.Map;
         all_reverse   : block_crate.Map;
         options       : package_crate.Map;
      end record;
   type port_record_access is access all port_record;

   type dim_make_queue is array (scanners) of subqueue.Vector;
   type dim_progress   is array (scanners) of port_index;
   type dim_all_ports  is array (port_index) of aliased port_record;

   all_ports    : dim_all_ports;
   ports_keys   : portkey_crate.Map;
   portlist     : portkey_crate.Map;
   make_queue   : dim_make_queue;
   mq_progress  : dim_progress := (others => 0);
   rank_queue   : ranking_crate.Set;
   number_cores : cpu_range  := cpu_range'First;
   lot_number   : scanners   := 1;
   lot_counter  : port_index := 0;
   last_port    : port_index := 0;
   prescanned   : Boolean    := False;

   procedure iterate_reverse_deps;
   procedure iterate_drill_down;
   procedure populate_set_depends (target  : port_index;
                                   catport : String;
                                   line    : JT.Text;
                                   dtype   : dependency_type);
   procedure populate_set_options (target  : port_index;
                                   line    : JT.Text;
                                   on      : Boolean);
   procedure populate_port_data   (target : port_index);
   procedure populate_port_data_fpc (target : port_index);
   procedure populate_port_data_nps (target : port_index);
   procedure drill_down (next_target     : port_index;
                         original_target : port_index);

   --  subroutines for populate_port_data
   procedure prescan_ports_tree (portsdir : String);
   procedure grep_Makefile (portsdir, category : String);
   procedure walk_all_subdirectories (portsdir, category : String);
   procedure wipe_make_queue;
   procedure parallel_deep_scan (success : out Boolean;
                                 show_progress : Boolean);

   --  some helper routines
   function find_colon (Source : String) return Natural;
   function scrub_phase (Source : String) return JT.Text;
   function get_catport (PR : port_record) return String;
   function scan_progress return String;
   function get_max_lots return scanners;
   function get_pkg_name (origin : String) return String;
   function timestamp (hack : CAL.Time; www_format : Boolean := False) return String;
   function clean_up_pkgsrc_ignore_reason (dirty_string : String) return JT.Text;

   type dim_counters is array (count_type) of Natural;

   --  bulk run variables
   Flog        : dim_handlers;
   start_time  : CAL.Time;
   stop_time   : CAL.Time;
   scan_start  : CAL.Time;
   scan_stop   : CAL.Time;
   bld_counter : dim_counters := (0, 0, 0, 0, 0);

end PortScan;

Bump maximum ports to 40,000

Bump maximum ports to 40,000

FreeBSD is nearly at 32,000 now.


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

--  = Logging =
--  The `Util.Log` package and children provide a simple logging framework inspired
--  from the Java Log4j library.  It is intended to provide a subset of logging features
--  available in other languages, be flexible, extensible, small and efficient.  Having
--  log messages in large applications is very helpful to understand, track and fix complex
--  issues, some of them being related to configuration issues or interaction with other
--  systems.  The overhead of calling a log operation is negligeable when the log is disabled
--  as it is in the order of 30ns and reasonable for a file appender has it is in the order
--  of 5us.
--
--  == Using the log framework ==
--  A bit of terminology:
--
--  * A *logger* is the abstraction that provides operations to emit a message.  The message
--    is composed of a text, optional formatting parameters, a log level and a timestamp.
--  * A *formatter* is the abstraction that takes the information about the log to format
--    the final message.
--  * An *appender* is the abstraction that writes the message either to a console, a file
--    or some other final mechanism.
--
--  === Logger Declaration ===
--  Similar to other logging framework such as Log4j and Log4cxx, it is necessary to have
--  and instance of a logger to write a log message.  The logger instance holds the configuration
--  for the log to enable, disable and control the format and the appender that will receive
--  the message.  The logger instance is associated with a name that is used for the
--  configuration.  A good practice is to declare a `Log` instance in the package body or
--  the package private part to make available the log instance to all the package operations.
--  The instance is created by using the `Create` function.  The name used for the configuration
--  is free but using the full package name is helpful to control precisely the logs.
--
--    with Util.Log.Loggers;
--    package body X.Y is
--      Log : constant Util.Log.Loggers := Util.Log.Loggers.Create ("X.Y");
--    end X.Y;
--
--  === Logger Messages ===
--  A log message is associated with a log level which is used by the logger instance to
--  decide to emit or drop the log message.  To keep the logging API simple and make it easily
--  usable in the application, several operations are provided to write a message with different
--  log level.
--
--  A log message is a string that contains optional formatting markers that follow more or
--  less the Java MessageFormat class.  A parameter is represented by a number enclosed by `{}`.
--  The first parameter is represented by `{0}`, the second by `{1}` and so on.
--
--  The example below shows several calls to emit a log message with different levels:
--
--     Log.Error ("Cannot open file {0}: {1}", Path, "File does not exist");
--     Log.Warn ("The file {0} is empty", Path);
--     Log.Info ("Opening file {0}", Path);
--     Log.Debug ("Reading line {0}", Line);
--
--  === Log Configuration ===
--  The log configuration uses property files close to the Apache Log4j and to the
--  Apache Log4cxx configuration files.
--  The configuration file contains several parts to configure the logging framework:
--
--  * First, the *appender* configuration indicates the appender that exists and can receive
--    a log message.
--  * Second, a root configuration allows to control the default behavior of the logging
--    framework.  The root configuration controls the default log level as well as the
--    appenders that can be used.
--  * Last, a logger configuration is defined to control the logging level more precisely
--    for each logger.
--
--  Here is a simple log configuration that creates a file appender where log messages are
--  written.  The file appender is given the name `result` and is configured to write the
--  messages in the file `my-log-file.log`.  The file appender will use the `level-message`
--  format for the layout of messages.  Last is the configuration of the `X.Y` logger
--  that will enable only messages starting from the `WARN` level.
--
--    log4j.rootCategory=DEBUG,result
--    log4j.appender.result=File
--    log4j.appender.result.File=my-log-file.log
--    log4j.appender.result.layout=level-message
--    log4j.logger.X.Y=WARN
--
--
package Util.Log is

   pragma Preelaborate;

   subtype Level_Type is Natural;

   FATAL_LEVEL : constant Level_Type := 0;
   ERROR_LEVEL : constant Level_Type := 5;
   WARN_LEVEL  : constant Level_Type := 7;
   INFO_LEVEL  : constant Level_Type := 10;
   DEBUG_LEVEL : constant Level_Type := 20;

   --  Get the log level name.
   function Get_Level_Name (Level : Level_Type) return String;

   --  Get the log level from the property value
   function Get_Level (Value   : in String;
                       Default : in Level_Type := INFO_LEVEL) return Level_Type;

   --  The <tt>Logging</tt> interface defines operations that can be implemented for a
   --  type to report errors or messages.
   type Logging is limited interface;

   procedure Error (Log     : in out Logging;
                    Message : in String) is abstract;

end Util.Log;

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

--  = Logging =
--  The `Util.Log` package and children provide a simple logging framework inspired
--  from the Java Log4j library.  It is intended to provide a subset of logging features
--  available in other languages, be flexible, extensible, small and efficient.  Having
--  log messages in large applications is very helpful to understand, track and fix complex
--  issues, some of them being related to configuration issues or interaction with other
--  systems.  The overhead of calling a log operation is negligeable when the log is disabled
--  as it is in the order of 30ns and reasonable for a file appender has it is in the order
--  of 5us.
--
--  == Using the log framework ==
--  A bit of terminology:
--
--  * A *logger* is the abstraction that provides operations to emit a message.  The message
--    is composed of a text, optional formatting parameters, a log level and a timestamp.
--  * A *formatter* is the abstraction that takes the information about the log to format
--    the final message.
--  * An *appender* is the abstraction that writes the message either to a console, a file
--    or some other final mechanism.
--
--  == Logger Declaration ==
--  Similar to other logging framework such as Log4j and Log4cxx, it is necessary to have
--  and instance of a logger to write a log message.  The logger instance holds the configuration
--  for the log to enable, disable and control the format and the appender that will receive
--  the message.  The logger instance is associated with a name that is used for the
--  configuration.  A good practice is to declare a `Log` instance in the package body or
--  the package private part to make available the log instance to all the package operations.
--  The instance is created by using the `Create` function.  The name used for the configuration
--  is free but using the full package name is helpful to control precisely the logs.
--
--    with Util.Log.Loggers;
--    package body X.Y is
--      Log : constant Util.Log.Loggers := Util.Log.Loggers.Create ("X.Y");
--    end X.Y;
--
--  == Logger Messages ==
--  A log message is associated with a log level which is used by the logger instance to
--  decide to emit or drop the log message.  To keep the logging API simple and make it easily
--  usable in the application, several operations are provided to write a message with different
--  log level.
--
--  A log message is a string that contains optional formatting markers that follow more or
--  less the Java `MessageFormat` class.  A parameter is represented by a number enclosed by `{}`.
--  The first parameter is represented by `{0}`, the second by `{1}` and so on.  Parameters are
--  replaced in the final message only when the message is enabled by the log configuration.
--  The use of parameters allows to avoid formatting the log message when the log is not used.
--
--  The example below shows several calls to emit a log message with different levels:
--
--     Log.Error ("Cannot open file {0}: {1}", Path, "File does not exist");
--     Log.Warn ("The file {0} is empty", Path);
--     Log.Info ("Opening file {0}", Path);
--     Log.Debug ("Reading line {0}", Line);
--
--  The logger also provides a special `Error` procedure that accepts an Ada exception
--  occurence as parameter.  The exception name and message are printed together with
--  the error message.  It is also possible to activate a complete traceback of the
--  exception and report it in the error message.  With this mechanism, an exception
--  can be handled and reported easily:
--
--     begin
--        ...
--     exception
--        when E : others =>
--           Log.Error ("Something bad occurred", E, Trace => True);
--     end;
--
--  == Log Configuration ==
--  The log configuration uses property files close to the Apache Log4j and to the
--  Apache Log4cxx configuration files.
--  The configuration file contains several parts to configure the logging framework:
--
--  * First, the *appender* configuration indicates the appender that exists and can receive
--    a log message.
--  * Second, a root configuration allows to control the default behavior of the logging
--    framework.  The root configuration controls the default log level as well as the
--    appenders that can be used.
--  * Last, a logger configuration is defined to control the logging level more precisely
--    for each logger.
--
--  Here is a simple log configuration that creates a file appender where log messages are
--  written.  The file appender is given the name `result` and is configured to write the
--  messages in the file `my-log-file.log`.  The file appender will use the `level-message`
--  format for the layout of messages.  Last is the configuration of the `X.Y` logger
--  that will enable only messages starting from the `WARN` level.
--
--    log4j.rootCategory=DEBUG,result
--    log4j.appender.result=File
--    log4j.appender.result.File=my-log-file.log
--    log4j.appender.result.layout=level-message
--    log4j.logger.X.Y=WARN
--
--
package Util.Log is

   pragma Preelaborate;

   subtype Level_Type is Natural;

   FATAL_LEVEL : constant Level_Type := 0;
   ERROR_LEVEL : constant Level_Type := 5;
   WARN_LEVEL  : constant Level_Type := 7;
   INFO_LEVEL  : constant Level_Type := 10;
   DEBUG_LEVEL : constant Level_Type := 20;

   --  Get the log level name.
   function Get_Level_Name (Level : Level_Type) return String;

   --  Get the log level from the property value
   function Get_Level (Value   : in String;
                       Default : in Level_Type := INFO_LEVEL) return Level_Type;

   --  The <tt>Logging</tt> interface defines operations that can be implemented for a
   --  type to report errors or messages.
   type Logging is limited interface;

   procedure Error (Log     : in out Logging;
                    Message : in String) is abstract;

end Util.Log;

Add some documentation

Add some documentation


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

package body EL.Methods.Proc_In is

   use EL.Expressions;

   --  ------------------------------
   --  Returns True if the method is a valid method which accepts the arguments
   --  defined by the package instantiation.
   --  ------------------------------
   function Is_Valid (Method : in EL.Expressions.Method_Info) return Boolean is
   begin
      if Method.Binding = null then
         return False;
      else
         return Method.Binding.all in Binding'Class;
      end if;
   end Is_Valid;

   --  ------------------------------
   --  Execute the method describe by the method binding object.
   --  The method signature is:
   --
   --   procedure F (Obj   : in out <Bean>;
   --                Param : in Param1_Type);
   --
   --  where <Bean> inherits from Readonly_Bean
   --  (See Bind package)
   --
   --  Raises Invalid_Method if the method referenced by
   --  the method expression does not exist or does not match
   --  the signature.
   --  ------------------------------
   procedure Execute (Method  : in EL.Expressions.Method_Info;
                      Param   : in Param1_Type) is
   begin
      if Method.Binding = null then
         raise EL.Expressions.Invalid_Method with "Method not found";
      end if;

      --  If the binding has the wrong type, we are trying to invoke
      --  a method with a different signature.
      if not (Method.Binding.all in Binding'Class) then
         raise EL.Expressions.Invalid_Method
         with "Invalid signature for method '" & Method.Binding.Name.all & "'";
      end if;
      declare
         Proxy  : constant Binding_Access := Binding (Method.Binding.all)'Access;
      begin
         Proxy.Method (Method.Object, Param);
      end;
   end Execute;

   --  ------------------------------
   --  Execute the method describe by the method expression
   --  and with the given context.  The method signature is:
   --
   --   procedure F (Obj   : in out <Bean>;
   --                Param : in Param1_Type);
   --
   --  where <Bean> inherits from Readonly_Bean
   --  (See Bind package)
   --
   --  Raises Invalid_Method if the method referenced by
   --  the method expression does not exist or does not match
   --  the signature.
   --  ------------------------------
   procedure Execute (Method  : in EL.Expressions.Method_Expression'Class;
                      Param   : in Param1_Type;
                      Context : in EL.Contexts.ELContext'Class) is
      Info : constant Method_Info := Method.Get_Method_Info (Context);
   begin
      Execute (Info, Param);
   end Execute;

   --  ------------------------------
   --  Proxy for the binding.
   --  The proxy declares the binding definition that links
   --  the name to the function and it implements the necessary
   --  object conversion to translate the Readonly_Bean
   --  object to the target object type.
   --  ------------------------------
   package body Bind is
      procedure Method_Access (O  : access Util.Beans.Basic.Readonly_Bean'Class;
                               P1 : in Param1_Type) is
         Object : constant access Bean := Bean (O.all)'Access;
      begin
         Method (Object.all, P1);
      end Method_Access;
   end Bind;

end EL.Methods.Proc_In;

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

package body EL.Methods.Proc_In is

   use EL.Expressions;

   --  ------------------------------
   --  Returns True if the method is a valid method which accepts the arguments
   --  defined by the package instantiation.
   --  ------------------------------
   function Is_Valid (Method : in EL.Expressions.Method_Info) return Boolean is
   begin
      if Method.Binding = null then
         return False;
      else
         return Method.Binding.all in Binding'Class;
      end if;
   end Is_Valid;

   --  ------------------------------
   --  Execute the method describe by the method binding object.
   --  The method signature is:
   --
   --   procedure F (Obj   : in out <Bean>;
   --                Param : in Param1_Type);
   --
   --  where <Bean> inherits from Readonly_Bean
   --  (See Bind package)
   --
   --  Raises Invalid_Method if the method referenced by
   --  the method expression does not exist or does not match
   --  the signature.
   --  ------------------------------
   procedure Execute (Method  : in EL.Expressions.Method_Info;
                      Param   : in Param1_Type) is
   begin
      if Method.Binding = null then
         raise EL.Expressions.Invalid_Method with "Method not found";
      end if;

      --  If the binding has the wrong type, we are trying to invoke
      --  a method with a different signature.
      if not (Method.Binding.all in Binding'Class) then
         raise EL.Expressions.Invalid_Method
         with "Invalid signature for method '" & Method.Binding.Name.all & "'";
      end if;
      declare
         Proxy  : constant Binding_Access := Binding (Method.Binding.all)'Access;
      begin
         Proxy.Method (Util.Beans.Objects.To_Bean (Method.Object), Param);
      end;
   end Execute;

   --  ------------------------------
   --  Execute the method describe by the method expression
   --  and with the given context.  The method signature is:
   --
   --   procedure F (Obj   : in out <Bean>;
   --                Param : in Param1_Type);
   --
   --  where <Bean> inherits from Readonly_Bean
   --  (See Bind package)
   --
   --  Raises Invalid_Method if the method referenced by
   --  the method expression does not exist or does not match
   --  the signature.
   --  ------------------------------
   procedure Execute (Method  : in EL.Expressions.Method_Expression'Class;
                      Param   : in Param1_Type;
                      Context : in EL.Contexts.ELContext'Class) is
      Info : constant Method_Info := Method.Get_Method_Info (Context);
   begin
      Execute (Info, Param);
   end Execute;

   --  ------------------------------
   --  Proxy for the binding.
   --  The proxy declares the binding definition that links
   --  the name to the function and it implements the necessary
   --  object conversion to translate the Readonly_Bean
   --  object to the target object type.
   --  ------------------------------
   package body Bind is
      procedure Method_Access (O  : access Util.Beans.Basic.Readonly_Bean'Class;
                               P1 : in Param1_Type) is
         Object : constant access Bean := Bean (O.all)'Access;
      begin
         Method (Object.all, P1);
      end Method_Access;
   end Bind;

end EL.Methods.Proc_In;

Update use of Method_Info record after change of type for the Object member


-----------------------------------------------------------------------
--  mat-frames - Representation of stack frames
--  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.Unchecked_Deallocation;
with Interfaces; use Interfaces;
with MAT.Types; use MAT.Types;
with Util.Log.Loggers;
package body MAT.Frames is

   procedure Free is
     new Ada.Unchecked_Deallocation (Frame, Frame_Type);

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("MAT.Frames.Targets");

   procedure Split (F     : in out Frame_Type;
                    Pos   : in Positive);

   procedure Add_Frame (F      : in Frame_Type;
                        Pc     : in Frame_Table;
                        Result : out Frame_Type);

   function Check (Frame : in Frame_Type) return Boolean is
      Parent : Frame_Type;
      Child  : Frame_Type;
      Found  : Boolean := False;
      Result : Boolean := True;
   begin
      if Frame = null then
         return False;
      end if;
      Parent := Frame.Parent;
      if Parent /= null then
         Child := Parent.Children;
         while Child /= null loop
            if Child = Frame then
               Found := True;
            end if;
            if Child.Parent /= Parent then
               Log.Error ("Invalid parent link");
               Result := False;
            end if;
            Child := Child.Next;
         end loop;
      end if;
      return Result;
   end Check;

   --  ------------------------------
   --  Return the parent frame.
   --  ------------------------------
   function Parent (Frame : in Frame_Type) return Frame_Type is
   begin
      if Frame = null then
         return null;
      else
         return Frame.Parent;
      end if;
   end Parent;

   --  ------------------------------
   --  Returns the backtrace of the current frame (up to the root).
   --  ------------------------------
   function Backtrace (Frame :  in Frame_Type) return Frame_Table is
      Pc      : Frame_Table (1 .. Frame.Depth);
      Current : Frame_Type := Frame;
      Pos     : Natural   := Current.Depth;
      New_Pos : Natural;
   begin
      while Current /= null and Pos /= 0 loop
         New_Pos := Pos - Current.Local_Depth + 1;
         Pc (New_Pos .. Pos) := Current.Calls (1 .. Current.Local_Depth);
         Pos     := New_Pos - 1;
         Current := Current.Parent;
      end loop;
      return Pc;
   end Backtrace;

   --  ------------------------------
   --  Returns the number of children in the frame.
   --  When recursive is true, compute in the sub-tree.
   --  ------------------------------
   function Count_Children (Frame     : in Frame_Type;
                            Recursive : in Boolean := False) return Natural is
      Count : Natural := 0;
      Child : Frame_Type;
   begin
      if Frame /= null then
         Child := Frame.Children;
         while Child /= null loop
            Count := Count + 1;
            if Recursive then
               declare
                  N : Natural := Count_Children (Child, True);
               begin
                  if N > 0 then
                     N := N - 1;
                  end if;
                  Count := Count + N;
               end;
            end if;
            Child := Child.Next;
         end loop;
      end if;
      return Count;
   end Count_Children;

   --  ------------------------------
   --  Returns all the direct calls made by the current frame.
   --  ------------------------------
   function Calls (Frame : in Frame_Type) return Frame_Table is
      Nb_Calls : constant Natural   := Count_Children (Frame);
      Pc       : Frame_Table (1 .. Nb_Calls);
   begin
      if Frame /= null then
         declare
            Child : Frame_Type := Frame.Children;
            Pos   : Natural   := 1;
         begin
            while Child /= null loop
               Pc (Pos) := Child.Calls (1);
               Pos   := Pos + 1;
               Child := Child.Next;
            end loop;
         end;
      end if;
      return Pc;
   end Calls;

   --  ------------------------------
   --  Returns the current stack depth (# of calls from the root
   --  to reach the frame).
   --  ------------------------------
   function Current_Depth (Frame : in Frame_Type) return Natural is
   begin
      if Frame = null then
         return 0;
      else
         return Frame.Depth;
      end if;
   end Current_Depth;

   --  ------------------------------
   --  Create a root for stack frame representation.
   --  ------------------------------
   function Create_Root return Frame_Type is
   begin
      return new Frame;
   end Create_Root;

   --  ------------------------------
   --  Destroy the frame tree recursively.
   --  ------------------------------
   procedure Destroy (Frame : in out Frame_Type) is
      F : Frame_Type;
   begin
      if Frame = null then
         return;
      end if;
      --  Destroy its children recursively.
      while Frame.Children /= null loop
         F := Frame.Children;
         Destroy (F);
      end loop;

      --  Unlink from parent list.
      if Frame.Parent /= null then
         F := Frame.Parent.Children;
         if F = Frame then
            Frame.Parent.Children := Frame.Next;
         else
            while F /= null and then F.Next /= Frame loop
               F := F.Next;
            end loop;
            if F = null then
               Log.Error ("Frame is not linked to the correct parent");
               return;
            else
               F.Next := Frame.Next;
            end if;
         end if;
      end if;
      Free (Frame);
   end Destroy;

   --  ------------------------------
   --  Release the frame when its reference is no longer necessary.
   --  ------------------------------
   procedure Release (Frame : in Frame_Type) is
      Current : Frame_Type := Frame;
   begin
      --  Scan the frame until the root is reached
      --  and decrement the used counter.  Free the frames
      --  when the used counter reaches 0.
      while Current /= null loop
         Current.Used := Current.Used - 1;
         if Current.Used = 0 then
            declare
               Tree : Frame_Type := Current;
            begin
               Current := Current.Parent;
               Destroy (Tree);
            end;
         else
            Current := Current.Parent;
         end if;
      end loop;
   end Release;

   --  ------------------------------
   --  Split the node pointed to by `F' at the position `Pos'
   --  in the caller chain.  A new parent is created for the node
   --  and the brothers of the node become the brothers of the
   --  new parent.
   --
   --  Returns in `F' the new parent node.
   --  ------------------------------
   procedure Split (F     : in out Frame_Type;
                    Pos   : in Positive) is

      --  Before:                       After:
      --
      --    +-------+             +-------+
      --  /-|  P    |           /-|  P    |
      --  | +-------+           | +-------+
      --  |       ^             |       ^
      --  |   +-------+         |    +-------+
      --  ...>| node  |...      ....>|  new  |...        (0..N brothers)
      --      +-------+              +-------+
      --       |     ^              |      ^
      --       | +-------+          | +-------+
      --       ->|  c    |          ->| node  |-->0      (0 brother)
      --         +-------+            +-------+
      --                                    |
      --                                +-------+
      --                                |   c   |
      --                                +-------+
      --
      New_Parent : constant Frame_Type := new Frame '(Parent      => F.Parent,
                                                      Next        => F.Next,
                                                      Children    => F,
                                                      Used        => F.Used - 1,
                                                      Depth       => F.Depth,
                                                      Local_Depth => Pos,
                                                      Calls       => (others => 0));
      Child : Frame_Type := F.Parent.Children;
   begin
      Log.Debug ("Split frame");

      --  Move the PC values in the new parent.
      New_Parent.Calls (1 .. Pos) := F.Calls (1 .. Pos);
      F.Calls (1 .. F.Local_Depth - Pos) := F.Calls (Pos + 1 .. F.Local_Depth);
      F.Parent         := New_Parent;
      F.Next           := null;
      F.Used           := F.Used - 1;
      New_Parent.Depth := F.Depth - F.Local_Depth + Pos;
      F.Local_Depth    := F.Local_Depth - Pos;

      --  Remove F from its parent children list and replace if with New_Parent.
      if Child = F then
         New_Parent.Parent.Children := New_Parent;
      else
         while Child.Next /= F loop
            Child := Child.Next;
         end loop;
         Child.Next := New_Parent;
      end if;
      F := New_Parent;
      if not Check (F) then
         Log.Error ("Error when splitting frame");
      end if;
   end Split;

   procedure Add_Frame (F      : in Frame_Type;
                        Pc     : in Frame_Table;
                        Result : out Frame_Type) is
      Child         : Frame_Type := F;
      Pos           : Positive   := Pc'First;
      Current_Depth : Natural    := F.Depth;
      Cnt           : Local_Depth_Type;
   begin
      while Pos <= Pc'Last loop
         Cnt := Frame_Group_Size;
         if Pos + Cnt > Pc'Last then
            Cnt := Pc'Last - Pos + 1;
         end if;
         Current_Depth := Current_Depth + Cnt;
         Child := new Frame '(Parent      => Child,
                              Next        => Child.Children,
                              Children    => null,
                              Used        => 1,
                              Depth       => Current_Depth,
                              Local_Depth => Cnt,
                              Calls       => (others => 0));
         Child.Calls (1 .. Cnt) := Pc (Pos .. Pos + Cnt - 1);
         Pos := Pos + Cnt;
         Child.Parent.Children := Child;
         if not Check (Child) then
            Log.Error ("Error when adding frame");
         end if;
      end loop;
      Result := Child;
   end Add_Frame;

   --  ------------------------------
   --  Insert in the frame tree the new stack frame represented by <tt>Pc</tt>.
   --  If the frame is already known, the frame reference counter is incremented.
   --  The frame represented by <tt>Pc</tt> is returned in <tt>Result</tt>.
   --  ------------------------------
   procedure Insert (Frame  : in Frame_Type;
                     Pc     : in Frame_Table;
                     Result : out Frame_Type) is
      Current : Frame_Type := Frame;
      Child   : Frame_Type;
      Pos     : Positive  := Pc'First;
      Lpos    : Positive  := 1;
      Addr    : Target_Addr;
   begin
      while Pos <= Pc'Last loop
         Addr := Pc (Pos);
         if Lpos <= Current.Local_Depth then
            if Addr = Current.Calls (Lpos) then
               Lpos := Lpos + 1;
               Pos  := Pos + 1;

               --  Split this node
            else
               if Lpos > 1 then
                  Split (Current, Lpos - 1);
               else
                  Current.Used := Current.Used + 1;
               end if;
               Add_Frame (Current, Pc (Pos .. Pc'Last), Result);
               return;
            end if;
         else
            --  Find the first child which has the address.
            Child := Current.Children;
            while Child /= null loop
               exit when Child.Calls (1) = Addr;
               Child := Child.Next;
            end loop;
            if Child = null then
               Current.Used := Current.Used + 1;
               Add_Frame (Current, Pc (Pos .. Pc'Last), Result);
               return;
            end if;
            Current := Child;
            Lpos    := 2;
            Pos     := Pos + 1;
            Current.Used := Current.Used + 1;
         end if;
      end loop;
      if Lpos <= Current.Local_Depth then
         Split (Current, Lpos - 1);
      end if;
      Result := Current;
   end Insert;

   --  ------------------------------
   --  Find the child frame which has the given PC address.
   --  Returns that frame pointer or raises the Not_Found exception.
   --  ------------------------------
   function Find (Frame : in Frame_Type;
                  Pc    : in Target_Addr) return Frame_Type is
      Child : Frame_Type := Frame.Children;
   begin
      while Child /= null loop
         if Child.Local_Depth >= 1 and then Child.Calls (1) = Pc then
            return Child;
         end if;
         Child := Child.Next;
      end loop;
      raise Not_Found;
   end Find;

   --  ------------------------------
   --  Find the child frame which has the given PC address.
   --  Returns that frame pointer or raises the Not_Found exception.
   --  ------------------------------
   function Find (Frame : in Frame_Type;
                  Pc    : in Frame_Table) return Frame_Type is
      Child : Frame_Type := Frame;
      Pos   : Positive  := Pc'First;
      Lpos  : Positive;
   begin
      while Pos <= Pc'Last loop
         Child := Find (Child, Pc (Pos));
         Pos  := Pos + 1;
         Lpos := 2;
         --  All the PC of the child frame must match.
         while Pos <= Pc'Last and Lpos <= Child.Local_Depth loop
            if Child.Calls (Lpos) /= Pc (Pos) then
               raise Not_Found;
            end if;
            Lpos := Lpos + 1;
            Pos  := Pos + 1;
         end loop;
      end loop;
      return Child;
   end Find;

   --  ------------------------------
   --  Find the child frame which has the given PC address.
   --  Returns that frame pointer or raises the Not_Found exception.
   --  ------------------------------
   procedure Find (Frame   : in Frame_Type;
                   Pc      : in Frame_Table;
                   Result  : out Frame_Type;
                   Last_Pc : out Natural) is
      Current : Frame_Type := Frame;
      Pos     : Positive  := Pc'First;
      Lpos    : Positive;
   begin
      Main_Search :
      while Pos <= Pc'Last loop
         declare
            Addr  : constant Target_Addr := Pc (Pos);
            Child : Frame_Type  := Current.Children;
         begin
            --  Find the child which has the corresponding PC.
            loop
               exit Main_Search when Child = null;
               exit when Child.Local_Depth >= 1 and Child.Calls (1) = Addr;
               Child := Child.Next;
            end loop;

            Current := Child;
            Pos  := Pos + 1;
            Lpos := 2;
            --  All the PC of the child frame must match.
            while Pos <= Pc'Last and Lpos <= Current.Local_Depth loop
               exit Main_Search when Current.Calls (Lpos) /= Pc (Pos);
               Lpos := Lpos + 1;
               Pos  := Pos + 1;
            end loop;
         end;
      end loop Main_Search;
      Result := Current;
      if Pos > Pc'Last then
         Last_Pc := 0;
      else
         Last_Pc := Pos;
      end if;
   end Find;

end MAT.Frames;

-----------------------------------------------------------------------
--  mat-frames - Representation of stack frames
--  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.Unchecked_Deallocation;
with Interfaces; use Interfaces;
with MAT.Types; use MAT.Types;
with Util.Log.Loggers;
package body MAT.Frames is

   procedure Free is
     new Ada.Unchecked_Deallocation (Frame, Frame_Type);

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("MAT.Frames.Targets");

   procedure Split (F     : in out Frame_Type;
                    Pos   : in Positive);

   procedure Add_Frame (F      : in Frame_Type;
                        Pc     : in Frame_Table;
                        Result : out Frame_Type);

   function Check (Frame : in Frame_Type) return Boolean is
      Parent : Frame_Type;
      Child  : Frame_Type;
      Found  : Boolean := False;
      Result : Boolean := True;
   begin
      if Frame = null then
         return False;
      end if;
      Parent := Frame.Parent;
      if Parent /= null then
         Child := Parent.Children;
         while Child /= null loop
            if Child = Frame then
               Found := True;
            end if;
            if Child.Parent /= Parent then
               Log.Error ("Invalid parent link");
               Result := False;
            end if;
            Child := Child.Next;
         end loop;
      end if;
      return Result;
   end Check;

   --  ------------------------------
   --  Return the parent frame.
   --  ------------------------------
   function Parent (Frame : in Frame_Type) return Frame_Type is
   begin
      if Frame = null then
         return null;
      else
         return Frame.Parent;
      end if;
   end Parent;

   --  ------------------------------
   --  Returns the backtrace of the current frame (up to the root).
   --  ------------------------------
   function Backtrace (Frame :  in Frame_Type) return Frame_Table is
      Pc      : Frame_Table (1 .. Frame.Depth);
      Current : Frame_Type := Frame;
      Pos     : Natural   := Current.Depth;
      New_Pos : Natural;
   begin
      while Current /= null and Pos /= 0 loop
         New_Pos := Pos - Current.Local_Depth + 1;
         Pc (New_Pos .. Pos) := Current.Calls (1 .. Current.Local_Depth);
         Pos     := New_Pos - 1;
         Current := Current.Parent;
      end loop;
      return Pc;
   end Backtrace;

   --  ------------------------------
   --  Returns the number of children in the frame.
   --  When recursive is true, compute in the sub-tree.
   --  ------------------------------
   function Count_Children (Frame     : in Frame_Type;
                            Recursive : in Boolean := False) return Natural is
      Count : Natural := 0;
      Child : Frame_Type;
   begin
      if Frame /= null then
         Child := Frame.Children;
         while Child /= null loop
            Count := Count + 1;
            if Recursive then
               declare
                  N : Natural := Count_Children (Child, True);
               begin
                  if N > 0 then
                     N := N - 1;
                  end if;
                  Count := Count + N;
               end;
            end if;
            Child := Child.Next;
         end loop;
      end if;
      return Count;
   end Count_Children;

   --  ------------------------------
   --  Returns all the direct calls made by the current frame.
   --  ------------------------------
   function Calls (Frame : in Frame_Type) return Frame_Table is
      Nb_Calls : constant Natural   := Count_Children (Frame);
      Pc       : Frame_Table (1 .. Nb_Calls);
   begin
      if Frame /= null then
         declare
            Child : Frame_Type := Frame.Children;
            Pos   : Natural   := 1;
         begin
            while Child /= null loop
               Pc (Pos) := Child.Calls (1);
               Pos   := Pos + 1;
               Child := Child.Next;
            end loop;
         end;
      end if;
      return Pc;
   end Calls;

   --  ------------------------------
   --  Returns the current stack depth (# of calls from the root
   --  to reach the frame).
   --  ------------------------------
   function Current_Depth (Frame : in Frame_Type) return Natural is
   begin
      if Frame = null then
         return 0;
      else
         return Frame.Depth;
      end if;
   end Current_Depth;

   --  ------------------------------
   --  Create a root for stack frame representation.
   --  ------------------------------
   function Create_Root return Frame_Type is
   begin
      return new Frame;
   end Create_Root;

   --  ------------------------------
   --  Destroy the frame tree recursively.
   --  ------------------------------
   procedure Destroy (Frame : in out Frame_Type) is
      F : Frame_Type;
   begin
      if Frame = null then
         return;
      end if;
      --  Destroy its children recursively.
      while Frame.Children /= null loop
         F := Frame.Children;
         Destroy (F);
      end loop;

      --  Unlink from parent list.
      if Frame.Parent /= null then
         F := Frame.Parent.Children;
         if F = Frame then
            Frame.Parent.Children := Frame.Next;
         else
            while F /= null and then F.Next /= Frame loop
               F := F.Next;
            end loop;
            if F = null then
               Log.Error ("Frame is not linked to the correct parent");
               return;
            else
               F.Next := Frame.Next;
            end if;
         end if;
      end if;
--        Free (Frame);
   end Destroy;

   --  ------------------------------
   --  Release the frame when its reference is no longer necessary.
   --  ------------------------------
   procedure Release (Frame : in Frame_Type) is
      Current : Frame_Type := Frame;
   begin
      --  Scan the frame until the root is reached
      --  and decrement the used counter.  Free the frames
      --  when the used counter reaches 0.
      while Current /= null loop
         if Current.Used <= 1 then
            declare
               Tree : Frame_Type := Current;
            begin
               Current := Current.Parent;
               Destroy (Tree);
            end;
         else
            Current.Used := Current.Used - 1;
            Current := Current.Parent;
         end if;
      end loop;
   end Release;

   --  ------------------------------
   --  Split the node pointed to by `F' at the position `Pos'
   --  in the caller chain.  A new parent is created for the node
   --  and the brothers of the node become the brothers of the
   --  new parent.
   --
   --  Returns in `F' the new parent node.
   --  ------------------------------
   procedure Split (F     : in out Frame_Type;
                    Pos   : in Positive) is

      --  Before:                       After:
      --
      --    +-------+             +-------+
      --  /-|  P    |           /-|  P    |
      --  | +-------+           | +-------+
      --  |       ^             |       ^
      --  |   +-------+         |    +-------+
      --  ...>| node  |...      ....>|  new  |...        (0..N brothers)
      --      +-------+              +-------+
      --       |     ^              |      ^
      --       | +-------+          | +-------+
      --       ->|  c    |          ->| node  |-->0      (0 brother)
      --         +-------+            +-------+
      --                                    |
      --                                +-------+
      --                                |   c   |
      --                                +-------+
      --
      New_Parent : constant Frame_Type := new Frame '(Parent      => F.Parent,
                                                      Next        => F.Next,
                                                      Children    => F,
                                                      Used        => F.Used - 1,
                                                      Depth       => F.Depth,
                                                      Local_Depth => Pos,
                                                      Calls       => (others => 0));
      Child : Frame_Type := F.Parent.Children;
   begin
      Log.Debug ("Split frame");

      --  Move the PC values in the new parent.
      New_Parent.Calls (1 .. Pos) := F.Calls (1 .. Pos);
      F.Calls (1 .. F.Local_Depth - Pos) := F.Calls (Pos + 1 .. F.Local_Depth);
      F.Parent         := New_Parent;
      F.Next           := null;
      F.Used           := F.Used - 1;
      New_Parent.Depth := F.Depth - F.Local_Depth + Pos;
      F.Local_Depth    := F.Local_Depth - Pos;

      --  Remove F from its parent children list and replace if with New_Parent.
      if Child = F then
         New_Parent.Parent.Children := New_Parent;
      else
         while Child.Next /= F loop
            Child := Child.Next;
         end loop;
         Child.Next := New_Parent;
      end if;
      F := New_Parent;
      if not Check (F) then
         Log.Error ("Error when splitting frame");
      end if;
   end Split;

   procedure Add_Frame (F      : in Frame_Type;
                        Pc     : in Frame_Table;
                        Result : out Frame_Type) is
      Child         : Frame_Type := F;
      Pos           : Positive   := Pc'First;
      Current_Depth : Natural    := F.Depth;
      Cnt           : Local_Depth_Type;
   begin
      while Pos <= Pc'Last loop
         Cnt := Frame_Group_Size;
         if Pos + Cnt > Pc'Last then
            Cnt := Pc'Last - Pos + 1;
         end if;
         Current_Depth := Current_Depth + Cnt;
         Child := new Frame '(Parent      => Child,
                              Next        => Child.Children,
                              Children    => null,
                              Used        => 1,
                              Depth       => Current_Depth,
                              Local_Depth => Cnt,
                              Calls       => (others => 0));
         Child.Calls (1 .. Cnt) := Pc (Pos .. Pos + Cnt - 1);
         Pos := Pos + Cnt;
         Child.Parent.Children := Child;
         if not Check (Child) then
            Log.Error ("Error when adding frame");
         end if;
      end loop;
      Result := Child;
   end Add_Frame;

   --  ------------------------------
   --  Insert in the frame tree the new stack frame represented by <tt>Pc</tt>.
   --  If the frame is already known, the frame reference counter is incremented.
   --  The frame represented by <tt>Pc</tt> is returned in <tt>Result</tt>.
   --  ------------------------------
   procedure Insert (Frame  : in Frame_Type;
                     Pc     : in Frame_Table;
                     Result : out Frame_Type) is
      Current : Frame_Type := Frame;
      Child   : Frame_Type;
      Pos     : Positive  := Pc'First;
      Lpos    : Positive  := 1;
      Addr    : Target_Addr;
   begin
      while Pos <= Pc'Last loop
         Addr := Pc (Pos);
         if Lpos <= Current.Local_Depth then
            if Addr = Current.Calls (Lpos) then
               Lpos := Lpos + 1;
               Pos  := Pos + 1;

               --  Split this node
            else
               Current.Used := Current.Used + 1;
               if Lpos > 1 then
                  Split (Current, Lpos - 1);
               end if;
               Add_Frame (Current, Pc (Pos .. Pc'Last), Result);
               return;
            end if;
         else
            --  Find the first child which has the address.
            Child := Current.Children;
            while Child /= null loop
               exit when Child.Calls (1) = Addr;
               Child := Child.Next;
            end loop;
            if Child = null then
               Current.Used := Current.Used + 1;
               Add_Frame (Current, Pc (Pos .. Pc'Last), Result);
               return;
            end if;
            Current.Used := Current.Used + 1;
            Current := Child;
            Lpos    := 2;
            Pos     := Pos + 1;
--              Current.Used := Current.Used + 1;
         end if;
      end loop;
      if Lpos <= Current.Local_Depth then
         Split (Current, Lpos - 1);
      end if;
      Result := Current;
   end Insert;

   --  ------------------------------
   --  Find the child frame which has the given PC address.
   --  Returns that frame pointer or raises the Not_Found exception.
   --  ------------------------------
   function Find (Frame : in Frame_Type;
                  Pc    : in Target_Addr) return Frame_Type is
      Child : Frame_Type := Frame.Children;
   begin
      while Child /= null loop
         if Child.Local_Depth >= 1 and then Child.Calls (1) = Pc then
            return Child;
         end if;
         Child := Child.Next;
      end loop;
      raise Not_Found;
   end Find;

   --  ------------------------------
   --  Find the child frame which has the given PC address.
   --  Returns that frame pointer or raises the Not_Found exception.
   --  ------------------------------
   function Find (Frame : in Frame_Type;
                  Pc    : in Frame_Table) return Frame_Type is
      Child : Frame_Type := Frame;
      Pos   : Positive  := Pc'First;
      Lpos  : Positive;
   begin
      while Pos <= Pc'Last loop
         Child := Find (Child, Pc (Pos));
         Pos  := Pos + 1;
         Lpos := 2;
         --  All the PC of the child frame must match.
         while Pos <= Pc'Last and Lpos <= Child.Local_Depth loop
            if Child.Calls (Lpos) /= Pc (Pos) then
               raise Not_Found;
            end if;
            Lpos := Lpos + 1;
            Pos  := Pos + 1;
         end loop;
      end loop;
      return Child;
   end Find;

   --  ------------------------------
   --  Find the child frame which has the given PC address.
   --  Returns that frame pointer or raises the Not_Found exception.
   --  ------------------------------
   procedure Find (Frame   : in Frame_Type;
                   Pc      : in Frame_Table;
                   Result  : out Frame_Type;
                   Last_Pc : out Natural) is
      Current : Frame_Type := Frame;
      Pos     : Positive  := Pc'First;
      Lpos    : Positive;
   begin
      Main_Search :
      while Pos <= Pc'Last loop
         declare
            Addr  : constant Target_Addr := Pc (Pos);
            Child : Frame_Type  := Current.Children;
         begin
            --  Find the child which has the corresponding PC.
            loop
               exit Main_Search when Child = null;
               exit when Child.Local_Depth >= 1 and Child.Calls (1) = Addr;
               Child := Child.Next;
            end loop;

            Current := Child;
            Pos  := Pos + 1;
            Lpos := 2;
            --  All the PC of the child frame must match.
            while Pos <= Pc'Last and Lpos <= Current.Local_Depth loop
               exit Main_Search when Current.Calls (Lpos) /= Pc (Pos);
               Lpos := Lpos + 1;
               Pos  := Pos + 1;
            end loop;
         end;
      end loop Main_Search;
      Result := Current;
      if Pos > Pc'Last then
         Last_Pc := 0;
      else
         Last_Pc := Pos;
      end if;
   end Find;

end MAT.Frames;

Fix frame management

Fix frame management


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

with Util.Beans.Objects;

--  The Gen.Model.Mappings package controls the mappings to convert an XML
--  type into the Ada type.
package Gen.Model.Mappings is

   ADA_MAPPING    : constant String := "Ada05";

   MySQL_MAPPING  : constant String := "MySQL";

   SQLite_MAPPING : constant String := "SQLite";

   type Basic_Type is (T_BOOLEAN, T_INTEGER, T_DATE, T_ENUM, T_IDENTIFIER, T_STRING, T_BLOB,
                       T_BEAN, T_TABLE);

   --  ------------------------------
   --  Mapping Definition
   --  ------------------------------
   type Mapping_Definition;
   type Mapping_Definition_Access is access all Mapping_Definition'Class;

   type Mapping_Definition is new Definition with record
      Target        : Ada.Strings.Unbounded.Unbounded_String;
      Kind          : Basic_Type := T_INTEGER;
      Allow_Null    : Mapping_Definition_Access;
      Nullable      : Boolean := False;
   end record;

   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   overriding
   function Get_Value (From : Mapping_Definition;
                       Name : String) return Util.Beans.Objects.Object;

   --  Find the mapping for the given type name.
   function Find_Type (Name       : in Ada.Strings.Unbounded.Unbounded_String;
                       Allow_Null : in Boolean)
                       return Mapping_Definition_Access;

   procedure Register_Type (Name    : in String;
                            Mapping : in Mapping_Definition_Access;
                            Kind    : in Basic_Type);

   --  Register a type mapping From that is mapped to Target.
   procedure Register_Type (Target        : in String;
                            From          : in String;
                            Kind          : in Basic_Type;
                            Allow_Null    : in Boolean);

   --  Setup the type mapping for the language identified by the given name.
   procedure Set_Mapping_Name (Name : in String);

   package Mapping_Maps is
     new Ada.Containers.Hashed_Maps (Key_Type        => Ada.Strings.Unbounded.Unbounded_String,
                                     Element_Type    => Mapping_Definition_Access,
                                     Hash            => Ada.Strings.Unbounded.Hash,
                                     Equivalent_Keys => Ada.Strings.Unbounded."=");

   subtype Map is Mapping_Maps.Map;

   subtype Cursor is Mapping_Maps.Cursor;

end Gen.Model.Mappings;

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

with Util.Beans.Objects;

--  The Gen.Model.Mappings package controls the mappings to convert an XML
--  type into the Ada type.
package Gen.Model.Mappings is

   ADA_MAPPING    : constant String := "Ada05";

   MySQL_MAPPING  : constant String := "MySQL";

   SQLite_MAPPING : constant String := "SQLite";

   type Basic_Type is (T_BOOLEAN, T_INTEGER, T_DATE, T_ENUM, T_IDENTIFIER, T_STRING, T_BLOB,
                       T_BEAN, T_TABLE);

   --  ------------------------------
   --  Mapping Definition
   --  ------------------------------
   type Mapping_Definition;
   type Mapping_Definition_Access is access all Mapping_Definition'Class;

   type Mapping_Definition is new Definition with record
      Target        : Ada.Strings.Unbounded.Unbounded_String;
      Kind          : Basic_Type := T_INTEGER;
      Allow_Null    : Mapping_Definition_Access;
      Nullable      : Boolean := False;
   end record;

   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   overriding
   function Get_Value (From : Mapping_Definition;
                       Name : String) return Util.Beans.Objects.Object;

   --  Find the mapping for the given type name.
   function Find_Type (Name       : in Ada.Strings.Unbounded.Unbounded_String;
                       Allow_Null : in Boolean)
                       return Mapping_Definition_Access;

   --  Get the type name.
   function Get_Type_Name (From : Mapping_Definition) return String;

   procedure Register_Type (Name    : in String;
                            Mapping : in Mapping_Definition_Access;
                            Kind    : in Basic_Type);

   --  Register a type mapping From that is mapped to Target.
   procedure Register_Type (Target        : in String;
                            From          : in String;
                            Kind          : in Basic_Type;
                            Allow_Null    : in Boolean);

   --  Setup the type mapping for the language identified by the given name.
   procedure Set_Mapping_Name (Name : in String);

   package Mapping_Maps is
     new Ada.Containers.Hashed_Maps (Key_Type        => Ada.Strings.Unbounded.Unbounded_String,
                                     Element_Type    => Mapping_Definition_Access,
                                     Hash            => Ada.Strings.Unbounded.Hash,
                                     Equivalent_Keys => Ada.Strings.Unbounded."=");

   subtype Map is Mapping_Maps.Map;

   subtype Cursor is Mapping_Maps.Cursor;

end Gen.Model.Mappings;

Declare the Get_Type_Name function

Declare the Get_Type_Name function


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

--  The <b>Util.Strings.Vectors</b> package provides an instantiation
--  of a vector container with Strings.
package Util.Strings.Vectors is new Ada.Containers.Indefinite_Vectors
  (Element_Type => String,
   Index_Type   => Positive);

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

--  The <b>Util.Strings.Vectors</b> package provides an instantiation
--  of a vector container with Strings.
package Util.Strings.Vectors is new Ada.Containers.Indefinite_Vectors
  (Element_Type => String,
   Index_Type   => Positive);

Update the header

Update the header


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

private with AWS.Headers;
private with AWS.Response;
package Util.Http.Clients.Web is

   --  Register the Http manager.
   procedure Register;

private

   type AWS_Http_Manager is new Http_Manager with null record;
   type AWS_Http_Manager_Access is access all Http_Manager'Class;

   procedure Create (Manager  : in AWS_Http_Manager;
                     Http     : in out Client'Class);

   overriding
   procedure Do_Get (Manager  : in AWS_Http_Manager;
                     Http     : in Client'Class;
                     URI      : in String;
                     Reply    : out Response'Class);

   overriding
   procedure Do_Post (Manager  : in AWS_Http_Manager;
                      Http     : in Client'Class;
                      URI      : in String;
                      Data     : in String;
                      Reply    : out Response'Class);

   overriding
   procedure Do_Put (Manager  : in AWS_Http_Manager;
                     Http     : in Client'Class;
                     URI      : in String;
                     Data     : in String;
                     Reply    : out Response'Class);

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

   type AWS_Http_Request is new Http_Request with record
      Headers : AWS.Headers.List;
   end record;
   type AWS_Http_Request_Access is access all AWS_Http_Request'Class;

   --  Returns a boolean indicating whether the named request header has already
   --  been set.
   overriding
   function Contains_Header (Http : in AWS_Http_Request;
                             Name : in String) return Boolean;

   --  Returns the value of the specified request header as a String. If the request
   --  did not include a header of the specified name, this method returns null.
   --  If there are multiple headers with the same name, this method returns the
   --  first head in the request. The header name is case insensitive. You can use
   --  this method with any response header.
   overriding
   function Get_Header (Request : in AWS_Http_Request;
                        Name    : in String) return String;

   --  Sets a request header with the given name and value. If the header had already
   --  been set, the new value overwrites the previous one. The containsHeader
   --  method can be used to test for the presence of a header before setting its value.
   overriding
   procedure Set_Header (Http  : in out AWS_Http_Request;
                         Name  : in String;
                         Value : in String);

   --  Adds a request header with the given name and value.
   --  This method allows request headers to have multiple values.
   overriding
   procedure Add_Header (Http  : in out AWS_Http_Request;
                         Name  : in String;
                         Value : in String);

   --  Iterate over the request headers and executes the Process procedure.
   overriding
   procedure Iterate_Headers (Request : in AWS_Http_Request;
                              Process : not null access
                                procedure (Name  : in String;
                                           Value : in String));

   type AWS_Http_Response is new Http_Response with record
      Data : AWS.Response.Data;
   end record;
   type AWS_Http_Response_Access is access all AWS_Http_Response'Class;

   --  Returns a boolean indicating whether the named response header has already
   --  been set.
   overriding
   function Contains_Header (Reply : in AWS_Http_Response;
                             Name  : in String) return Boolean;

   --  Returns the value of the specified response header as a String. If the response
   --  did not include a header of the specified name, this method returns null.
   --  If there are multiple headers with the same name, this method returns the
   --  first head in the request. The header name is case insensitive. You can use
   --  this method with any response header.
   overriding
   function Get_Header (Reply  : in AWS_Http_Response;
                        Name   : in String) return String;

   --  Sets a message header with the given name and value. If the header had already
   --  been set, the new value overwrites the previous one. The containsHeader
   --  method can be used to test for the presence of a header before setting its value.
   overriding
   procedure Set_Header (Reply    : in out AWS_Http_Response;
                         Name     : in String;
                         Value    : in String);

   --  Adds a request header with the given name and value.
   --  This method allows request headers to have multiple values.
   overriding
   procedure Add_Header (Reply   : in out AWS_Http_Response;
                         Name    : in String;
                         Value   : in String);

   --  Iterate over the response headers and executes the Process procedure.
   overriding
   procedure Iterate_Headers (Reply   : in AWS_Http_Response;
                              Process : not null access
                                procedure (Name  : in String;
                                           Value : in String));

   --  Get the response body as a string.
   function Get_Body (Reply : in AWS_Http_Response) return String;

   --  Get the response status code.
   overriding
   function Get_Status (Reply : in AWS_Http_Response) return Natural;

end Util.Http.Clients.Web;

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

private with AWS.Headers;
private with AWS.Response;
private with AWS.Client;
package Util.Http.Clients.Web is

   --  Register the Http manager.
   procedure Register;

private

   type AWS_Http_Manager is new Http_Manager with record
      Timeout : Duration := 60.0;
   end record;
   type AWS_Http_Manager_Access is access all Http_Manager'Class;

   procedure Create (Manager  : in AWS_Http_Manager;
                     Http     : in out Client'Class);

   overriding
   procedure Do_Get (Manager  : in AWS_Http_Manager;
                     Http     : in Client'Class;
                     URI      : in String;
                     Reply    : out Response'Class);

   overriding
   procedure Do_Post (Manager  : in AWS_Http_Manager;
                      Http     : in Client'Class;
                      URI      : in String;
                      Data     : in String;
                      Reply    : out Response'Class);

   overriding
   procedure Do_Put (Manager  : in AWS_Http_Manager;
                     Http     : in Client'Class;
                     URI      : in String;
                     Data     : in String;
                     Reply    : out Response'Class);

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

   type AWS_Http_Request is new Http_Request with record
      Timeouts : AWS.Client.Timeouts_Values := AWS.Client.No_Timeout;
      Headers  : AWS.Headers.List;
   end record;
   type AWS_Http_Request_Access is access all AWS_Http_Request'Class;

   --  Returns a boolean indicating whether the named request header has already
   --  been set.
   overriding
   function Contains_Header (Http : in AWS_Http_Request;
                             Name : in String) return Boolean;

   --  Returns the value of the specified request header as a String. If the request
   --  did not include a header of the specified name, this method returns null.
   --  If there are multiple headers with the same name, this method returns the
   --  first head in the request. The header name is case insensitive. You can use
   --  this method with any response header.
   overriding
   function Get_Header (Request : in AWS_Http_Request;
                        Name    : in String) return String;

   --  Sets a request header with the given name and value. If the header had already
   --  been set, the new value overwrites the previous one. The containsHeader
   --  method can be used to test for the presence of a header before setting its value.
   overriding
   procedure Set_Header (Http  : in out AWS_Http_Request;
                         Name  : in String;
                         Value : in String);

   --  Adds a request header with the given name and value.
   --  This method allows request headers to have multiple values.
   overriding
   procedure Add_Header (Http  : in out AWS_Http_Request;
                         Name  : in String;
                         Value : in String);

   --  Iterate over the request headers and executes the Process procedure.
   overriding
   procedure Iterate_Headers (Request : in AWS_Http_Request;
                              Process : not null access
                                procedure (Name  : in String;
                                           Value : in String));

   type AWS_Http_Response is new Http_Response with record
      Data : AWS.Response.Data;
   end record;
   type AWS_Http_Response_Access is access all AWS_Http_Response'Class;

   --  Returns a boolean indicating whether the named response header has already
   --  been set.
   overriding
   function Contains_Header (Reply : in AWS_Http_Response;
                             Name  : in String) return Boolean;

   --  Returns the value of the specified response header as a String. If the response
   --  did not include a header of the specified name, this method returns null.
   --  If there are multiple headers with the same name, this method returns the
   --  first head in the request. The header name is case insensitive. You can use
   --  this method with any response header.
   overriding
   function Get_Header (Reply  : in AWS_Http_Response;
                        Name   : in String) return String;

   --  Sets a message header with the given name and value. If the header had already
   --  been set, the new value overwrites the previous one. The containsHeader
   --  method can be used to test for the presence of a header before setting its value.
   overriding
   procedure Set_Header (Reply    : in out AWS_Http_Response;
                         Name     : in String;
                         Value    : in String);

   --  Adds a request header with the given name and value.
   --  This method allows request headers to have multiple values.
   overriding
   procedure Add_Header (Reply   : in out AWS_Http_Response;
                         Name    : in String;
                         Value   : in String);

   --  Iterate over the response headers and executes the Process procedure.
   overriding
   procedure Iterate_Headers (Reply   : in AWS_Http_Response;
                              Process : not null access
                                procedure (Name  : in String;
                                           Value : in String));

   --  Get the response body as a string.
   function Get_Body (Reply : in AWS_Http_Response) return String;

   --  Get the response status code.
   overriding
   function Get_Status (Reply : in AWS_Http_Response) return Natural;

end Util.Http.Clients.Web;

Add timeouts to the HTTP requests

Add timeouts to the HTTP requests