-----------------------------------------------------------------------
--  util-log-appenders-rolling_files -- Rolling file log appenders
--  Copyright (C) 2001 - 2021 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.Finalization;
with Ada.Directories;
with Util.Properties.Basic;
with Util.Log.Appenders.Formatter;
package body Util.Log.Appenders.Rolling_Files is

   use Ada;
   use Ada.Finalization;

   package Bool_Prop renames Util.Properties.Basic.Boolean_Property;
   package Int_Prop renames Util.Properties.Basic.Integer_Property;

   --  ------------------------------
   --  Finalize the referenced object.  This is called before the object is freed.
   --  ------------------------------
   overriding
   procedure Finalize (Object : in out File_Entity) is
   begin
      Text_IO.Close (File => Object.Output);
   end Finalize;

   protected body Rolling_File is

      procedure Initialize (Name       : in String;
                            Base       : in String;
                            Properties : in Util.Properties.Manager) is
         function Get_Policy return Util.Files.Rolling.Policy_Type with Inline;
         function Get_Strategy return Util.Files.Rolling.Strategy_Type with Inline;

         File  : constant String := Properties.Get (Base & ".fileName", Name & ".log");
         Pat   : constant String := Properties.Get (Base & ".filePattern", Base & "-%i.log");

         function Get_Policy return Util.Files.Rolling.Policy_Type is
            Str   : constant String := Properties.Get (Base & ".policy", "time");
            Inter : constant Integer := Int_Prop.Get (Properties, Base & ".policyInterval", 1);
            Size  : constant String := Properties.Get (Base & ".minSize", "1000000");
         begin
            if Str = "none" then
               return (Kind => Util.Files.Rolling.No_Policy);
            elsif Str = "time" then
               return (Kind     => Util.Files.Rolling.Time_Policy,
                       Interval => Inter);
            else
               return (Kind => Util.Files.Rolling.Size_Policy,
                       Size => Ada.Directories.File_Size'Value (Size));
            end if;

         exception
            when others =>
               return (Kind => Util.Files.Rolling.No_Policy);
         end Get_Policy;

         function Get_Strategy return Util.Files.Rolling.Strategy_Type is
            Str   : constant String := Properties.Get (Base & ".strategy", "ascending");
            Min   : constant Integer := Int_Prop.Get (Properties, Base & ".policyMin", 0);
            Max   : constant Integer := Int_Prop.Get (Properties, Base & ".policyMax", 0);
         begin
            if Str = "direct" then
               return (Kind => Util.Files.Rolling.Direct_Strategy,
                       Max_Files => Max);

            elsif Str = "descending" then
               return (Kind      => Util.Files.Rolling.Descending_Strategy,
                       Min_Index => Min,
                       Max_Index => Max);

            else
               return (Kind      => Util.Files.Rolling.Ascending_Strategy,
                       Min_Index => Min,
                       Max_Index => Max);

            end if;
         end Get_Strategy;
      begin
         Append := Bool_Prop.Get (Properties, Base & ".append", True);
         Manager.Initialize (Path     => File,
                             Pattern  => Pat,
                             Policy   => Get_Policy,
                             Strategy => Get_Strategy);
      end Initialize;

      procedure Openlog (File : out File_Refs.Ref) is
      begin
         if not Manager.Is_Rollover_Necessary then
            File := Current;
            return;
         end if;

         Closelog;
         Current := File_Refs.Create;

         Manager.Rollover;

         declare
            Path : constant String := Manager.Get_Current_Path;
            Dir  : constant String := Ada.Directories.Containing_Directory (Path);
         begin
            if not Ada.Directories.Exists (Dir) then
               Ada.Directories.Create_Path (Dir);
            end if;

            if not Ada.Directories.Exists (Path) then
               Text_IO.Create (File => Current.Value.Output,
                               Name => Path);
            else
               Text_IO.Open (File => Current.Value.Output,
                             Name => Path,
                             Mode => (if Append then Text_IO.Append_File
                                      else Text_IO.Out_File));
            end if;
         end;
      end Openlog;

      procedure Flush (File : out File_Refs.Ref) is
      begin
         if not Current.Is_Null then
            File := Current;
         end if;
      end Flush;

      procedure Closelog is
         Empty : File_Refs.Ref;
      begin
         --  Close the current log by releasing its reference counter.
         Current := Empty;
      end Closelog;

   end Rolling_File;

   overriding
   procedure Append (Self    : in out File_Appender;
                     Message : in Util.Strings.Builders.Builder;
                     Date    : in Ada.Calendar.Time;
                     Level   : in Level_Type;
                     Logger  : in String) is

   begin
      if Self.Level >= Level then
         declare
            File : File_Refs.Ref;

            procedure Write_File (Data : in String) with Inline_Always;

            procedure Write_File (Data : in String) is
            begin
               Text_IO.Put (File.Value.Output, Data);
            end Write_File;

            procedure Write is new Formatter (Write_File);
         begin
            Self.File.Openlog (File);
            if not File.Is_Null then
               Write (Self, Message, Date, Level, Logger);
               Text_IO.New_Line (File.Value.Output);
               if Self.Immediate_Flush then
                  Text_IO.Flush (File.Value.Output);
               end if;
            end if;
         end;
      end if;
   end Append;

   --  ------------------------------
   --  Flush the log events.
   --  ------------------------------
   overriding
   procedure Flush (Self   : in out File_Appender) is
      File : File_Refs.Ref;
   begin
      Self.File.Flush (File);
      if not File.Is_Null then
         Text_IO.Flush (File.Value.Output);
      end if;
   end Flush;

   --  ------------------------------
   --  Flush and close the file.
   --  ------------------------------
   overriding
   procedure Finalize (Self : in out File_Appender) is
   begin
      Self.File.Closelog;
   end Finalize;

   --  ------------------------------
   --  Create a file appender and configure it according to the properties
   --  ------------------------------
   function Create (Name       : in String;
                    Properties : in Util.Properties.Manager;
                    Default    : in Level_Type)
                   return Appender_Access is
      Base    : constant String := "appender." & Name;
      Result  : constant File_Appender_Access
        := new File_Appender '(Limited_Controlled with Length => Name'Length,
                               Name => Name,
                               others => <>);
   begin
      Result.Set_Level (Name, Properties, Default);
      Result.Set_Layout (Name, Properties, FULL);
      Result.Immediate_Flush := Bool_Prop.Get (Properties, Base & ".immediateFlush", True);
      Result.File.Initialize (Name, Base, Properties);
      return Result.all'Access;
   end Create;

end Util.Log.Appenders.Rolling_Files;

-----------------------------------------------------------------------
--  util-log-appenders-rolling_files -- Rolling file log appenders
--  Copyright (C) 2001 - 2021 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.Finalization;
with Ada.Directories;
with Util.Properties.Basic;
with Util.Log.Appenders.Formatter;
package body Util.Log.Appenders.Rolling_Files is

   use Ada;
   use Ada.Finalization;

   package Bool_Prop renames Util.Properties.Basic.Boolean_Property;
   package Int_Prop renames Util.Properties.Basic.Integer_Property;

   --  ------------------------------
   --  Finalize the referenced object.  This is called before the object is freed.
   --  ------------------------------
   overriding
   procedure Finalize (Object : in out File_Entity) is
   begin
      Text_IO.Close (File => Object.Output);
   end Finalize;

   protected body Rolling_File is

      procedure Initialize (Name       : in String;
                            Base       : in String;
                            Properties : in Util.Properties.Manager) is
         function Get_Policy return Util.Files.Rolling.Policy_Type with Inline;
         function Get_Strategy return Util.Files.Rolling.Strategy_Type with Inline;

         File  : constant String := Properties.Get (Base & ".fileName", Name & ".log");
         Pat   : constant String := Properties.Get (Base & ".filePattern", Base & "-%i.log");

         function Get_Policy return Util.Files.Rolling.Policy_Type is
            Str   : constant String := Properties.Get (Base & ".policy", "time");
            Inter : constant Integer := Int_Prop.Get (Properties, Base & ".policyInterval", 1);
            Size  : constant String := Properties.Get (Base & ".minSize", "1000000");
         begin
            if Str = "none" then
               return (Kind => Util.Files.Rolling.No_Policy);
            elsif Str = "time" then
               return (Kind     => Util.Files.Rolling.Time_Policy,
                       Interval => Inter);
            else
               return (Kind => Util.Files.Rolling.Size_Policy,
                       Size => Ada.Directories.File_Size'Value (Size));
            end if;

         exception
            when others =>
               return (Kind => Util.Files.Rolling.No_Policy);
         end Get_Policy;

         function Get_Strategy return Util.Files.Rolling.Strategy_Type is
            Str   : constant String := Properties.Get (Base & ".strategy", "ascending");
            Min   : constant Integer := Int_Prop.Get (Properties, Base & ".policyMin", 0);
            Max   : constant Integer := Int_Prop.Get (Properties, Base & ".policyMax", 0);
         begin
            if Str = "direct" then
               return (Kind => Util.Files.Rolling.Direct_Strategy,
                       Max_Files => Max);

            elsif Str = "descending" then
               return (Kind      => Util.Files.Rolling.Descending_Strategy,
                       Min_Index => Min,
                       Max_Index => Max);

            else
               return (Kind      => Util.Files.Rolling.Ascending_Strategy,
                       Min_Index => Min,
                       Max_Index => Max);

            end if;
         end Get_Strategy;
      begin
         Append := Bool_Prop.Get (Properties, Base & ".append", True);
         Manager.Initialize (Path     => File,
                             Pattern  => Pat,
                             Policy   => Get_Policy,
                             Strategy => Get_Strategy);
      end Initialize;

      procedure Openlog (File : out File_Refs.Ref) is
      begin
         if not Current.Is_Null then
              if not Manager.Is_Rollover_Necessary then
               File := Current;
               return;
            end if;

            Closelog;
            Manager.Rollover;
         end if;

         Current := File_Refs.Create;
         declare
            Path : constant String := Manager.Get_Current_Path;
            Dir  : constant String := Ada.Directories.Containing_Directory (Path);
         begin
            if not Ada.Directories.Exists (Dir) then
               Ada.Directories.Create_Path (Dir);
            end if;

            if not Ada.Directories.Exists (Path) then
               Text_IO.Create (File => Current.Value.Output,
                               Name => Path);
            else
               Text_IO.Open (File => Current.Value.Output,
                             Name => Path,
                             Mode => (if Append then Text_IO.Append_File
                                      else Text_IO.Out_File));
            end if;
         end;
      end Openlog;

      procedure Flush (File : out File_Refs.Ref) is
      begin
         if not Current.Is_Null then
            File := Current;
         end if;
      end Flush;

      procedure Closelog is
         Empty : File_Refs.Ref;
      begin
         --  Close the current log by releasing its reference counter.
         Current := Empty;
      end Closelog;

   end Rolling_File;

   overriding
   procedure Append (Self    : in out File_Appender;
                     Message : in Util.Strings.Builders.Builder;
                     Date    : in Ada.Calendar.Time;
                     Level   : in Level_Type;
                     Logger  : in String) is

   begin
      if Self.Level >= Level then
         declare
            File : File_Refs.Ref;

            procedure Write_File (Data : in String) with Inline_Always;

            procedure Write_File (Data : in String) is
            begin
               Text_IO.Put (File.Value.Output, Data);
            end Write_File;

            procedure Write is new Formatter (Write_File);
         begin
            Self.File.Openlog (File);
            if not File.Is_Null then
               Write (Self, Message, Date, Level, Logger);
               Text_IO.New_Line (File.Value.Output);
               if Self.Immediate_Flush then
                  Text_IO.Flush (File.Value.Output);
               end if;
            end if;
         end;
      end if;
   end Append;

   --  ------------------------------
   --  Flush the log events.
   --  ------------------------------
   overriding
   procedure Flush (Self   : in out File_Appender) is
      File : File_Refs.Ref;
   begin
      Self.File.Flush (File);
      if not File.Is_Null then
         Text_IO.Flush (File.Value.Output);
      end if;
   end Flush;

   --  ------------------------------
   --  Flush and close the file.
   --  ------------------------------
   overriding
   procedure Finalize (Self : in out File_Appender) is
   begin
      Self.File.Closelog;
   end Finalize;

   --  ------------------------------
   --  Create a file appender and configure it according to the properties
   --  ------------------------------
   function Create (Name       : in String;
                    Properties : in Util.Properties.Manager;
                    Default    : in Level_Type)
                   return Appender_Access is
      Base    : constant String := "appender." & Name;
      Result  : constant File_Appender_Access
        := new File_Appender '(Limited_Controlled with Length => Name'Length,
                               Name => Name,
                               others => <>);
   begin
      Result.Set_Level (Name, Properties, Default);
      Result.Set_Layout (Name, Properties, FULL);
      Result.Immediate_Flush := Bool_Prop.Get (Properties, Base & ".immediateFlush", True);
      Result.File.Initialize (Name, Base, Properties);
      return Result.all'Access;
   end Create;

end Util.Log.Appenders.Rolling_Files;

Fix opening the first log

Fix opening the first log


-----------------------------------------------------------------------
--  gen-artifacts-yaml -- Yaml database model files
--  Copyright (C) 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 Gen.Model.Packages;

package Gen.Artifacts.Yaml is

   --  ------------------------------
   --  Yaml artifact
   --  ------------------------------
   type Artifact is new Gen.Artifacts.Artifact with private;

   --  Prepare the model after all the configuration files have been read and before
   --  actually invoking the generation.
   overriding
   procedure Prepare (Handler : in out Artifact;
                      Model   : in out Gen.Model.Packages.Model_Definition'Class;
                      Context : in out Generator'Class);

   --  Read the UML/XMI model file.
   procedure Read_Model (Handler       : in out Artifact;
                         File          : in String;
                         Model         : in out Gen.Model.Packages.Model_Definition;
                         Context       : in out Generator'Class;
                         Is_Predefined : in Boolean := False);

private

   type Artifact is new Gen.Artifacts.Artifact with null record;

end Gen.Artifacts.Yaml;

-----------------------------------------------------------------------
--  gen-artifacts-yaml -- Yaml database model files
--  Copyright (C) 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 Gen.Model.Packages;

package Gen.Artifacts.Yaml is

   --  ------------------------------
   --  Yaml artifact
   --  ------------------------------
   type Artifact is new Gen.Artifacts.Artifact with private;

   --  Prepare the model after all the configuration files have been read and before
   --  actually invoking the generation.
   overriding
   procedure Prepare (Handler : in out Artifact;
                      Model   : in out Gen.Model.Packages.Model_Definition'Class;
                      Context : in out Generator'Class);

   --  Read the UML/XMI model file.
   procedure Read_Model (Handler       : in out Artifact;
                         File          : in String;
                         Model         : in out Gen.Model.Packages.Model_Definition;
                         Context       : in out Generator'Class);

private

   type Artifact is new Gen.Artifacts.Artifact with null record;

end Gen.Artifacts.Yaml;

Fix compilation warnings

Fix compilation warnings


--  Generated by utildgen.c from system includes
with Interfaces.C;
package Util.Systems.Types is

   subtype dev_t is Interfaces.C.unsigned;
   subtype ino_t is Long_Long_Integer;
   subtype off_t is Long_Long_Integer;
   subtype blksize_t is Interfaces.C.int;
   subtype blkcnt_t is Long_Long_Integer;
   subtype uid_t is Interfaces.C.unsigned;
   subtype gid_t is Interfaces.C.unsigned;
   subtype nlink_t is Interfaces.C.unsigned_short;
   subtype mode_t is Interfaces.C.unsigned_short;

   S_IFMT   : constant mode_t := 8#00170000#;
   S_IFDIR  : constant mode_t := 8#00040000#;
   S_IFCHR  : constant mode_t := 8#00020000#;
   S_IFBLK  : constant mode_t := 8#00060000#;
   S_IFREG  : constant mode_t := 8#00100000#;
   S_IFIFO  : constant mode_t := 8#00010000#;
   S_IFLNK  : constant mode_t := 8#00120000#;
   S_IFSOCK : constant mode_t := 8#00140000#;
   S_ISUID  : constant mode_t := 8#00004000#;
   S_ISGID  : constant mode_t := 8#00002000#;
   S_IREAD  : constant mode_t := 8#00000400#;
   S_IWRITE : constant mode_t := 8#00000200#;
   S_IEXEC  : constant mode_t := 8#00000100#;

   type File_Type is new Interfaces.C.int;
   subtype Time_Type is Long_Long_Integer;

   type Timespec is record
      tv_sec  : Time_Type;
      tv_nsec : Long_Long_Integer;
   end record;
   pragma Convention (C_Pass_By_Copy, Timespec);

   type Seek_Mode is (SEEK_SET, SEEK_CUR, SEEK_END);
   for Seek_Mode use (SEEK_SET => 0, SEEK_CUR => 1, SEEK_END => 2);

   --  Size = 144
   --  st_dev = 4
   --  st_mode = 2
   --  st_uid = 4
   --  st_atim = 8
   --  st_nlink@ 6
   --  st_rdev@ 24
   --  st_size@ 96
   STAT_NAME  : constant String := "_stat64";
   FSTAT_NAME : constant String := "_fstat64";
   type Stat_Type is record
      st_dev      : dev_t;
      st_mode     : mode_t;
      st_nlink    : nlink_t;
      st_ino      : ino_t;
      st_uid      : uid_t;
      st_gid      : gid_t;
      st_rdev     : dev_t;
      st_atim     : Timespec;
      st_mtim     : Timespec;
      st_ctim     : Timespec;
      st_birthtim : Timespec;
      st_size     : off_t;
      st_blocks   : blkcnt_t;
      st_blksize  : blksize_t;
      st_flags    : Interfaces.C.unsigned;
      st_gen      : Interfaces.C.unsigned;
      st_lspare   : Interfaces.C.unsigned;
      st_qspare1  : Interfaces.C.unsigned;
      st_qspare2  : Interfaces.C.unsigned;
      st_qspare3  : Interfaces.C.unsigned;
      st_qspare4  : Interfaces.C.unsigned;
   end record;
   pragma Convention (C_Pass_By_Copy, Stat_Type);

end Util.Systems.Types;

--  Generated by utildgen.c from system includes
with Interfaces.C;
package Util.Systems.Types is

   subtype dev_t is Interfaces.C.unsigned;
   subtype ino_t is Long_Long_Integer;
   subtype off_t is Long_Long_Integer;
   subtype blksize_t is Interfaces.C.int;
   subtype blkcnt_t is Long_Long_Integer;
   subtype uid_t is Interfaces.C.unsigned;
   subtype gid_t is Interfaces.C.unsigned;
   subtype nlink_t is Interfaces.C.unsigned_short;
   subtype mode_t is Interfaces.C.unsigned_short;

   S_IFMT   : constant mode_t := 8#00170000#;
   S_IFDIR  : constant mode_t := 8#00040000#;
   S_IFCHR  : constant mode_t := 8#00020000#;
   S_IFBLK  : constant mode_t := 8#00060000#;
   S_IFREG  : constant mode_t := 8#00100000#;
   S_IFIFO  : constant mode_t := 8#00010000#;
   S_IFLNK  : constant mode_t := 8#00120000#;
   S_IFSOCK : constant mode_t := 8#00140000#;
   S_ISUID  : constant mode_t := 8#00004000#;
   S_ISGID  : constant mode_t := 8#00002000#;
   S_IREAD  : constant mode_t := 8#00000400#;
   S_IWRITE : constant mode_t := 8#00000200#;
   S_IEXEC  : constant mode_t := 8#00000100#;

   type File_Type is new Interfaces.C.int;
   subtype Time_Type is Long_Long_Integer;

   type Timespec is record
      tv_sec  : Time_Type;
      tv_nsec : Long_Long_Integer;
   end record;
   pragma Convention (C_Pass_By_Copy, Timespec);

   type Seek_Mode is (SEEK_SET, SEEK_CUR, SEEK_END);
   for Seek_Mode use (SEEK_SET => 0, SEEK_CUR => 1, SEEK_END => 2);

   --  Size = 144
   --  st_dev = 4
   --  st_mode = 2
   --  st_uid = 4
   --  st_atim = 8
   --  st_nlink@ 6
   --  st_rdev@ 24
   --  st_size@ 96
   STAT_NAME  : constant String := "_stat64";
   LSTAT_NAME  : constant String := "_lstat64";
   FSTAT_NAME : constant String := "_fstat64";
   type Stat_Type is record
      st_dev      : dev_t;
      st_mode     : mode_t;
      st_nlink    : nlink_t;
      st_ino      : ino_t;
      st_uid      : uid_t;
      st_gid      : gid_t;
      st_rdev     : dev_t;
      st_atim     : Timespec;
      st_mtim     : Timespec;
      st_ctim     : Timespec;
      st_birthtim : Timespec;
      st_size     : off_t;
      st_blocks   : blkcnt_t;
      st_blksize  : blksize_t;
      st_flags    : Interfaces.C.unsigned;
      st_gen      : Interfaces.C.unsigned;
      st_lspare   : Interfaces.C.unsigned;
      st_qspare1  : Interfaces.C.unsigned;
      st_qspare2  : Interfaces.C.unsigned;
      st_qspare3  : Interfaces.C.unsigned;
      st_qspare4  : Interfaces.C.unsigned;
   end record;
   pragma Convention (C_Pass_By_Copy, Stat_Type);

end Util.Systems.Types;

Add LSTAT_NAME for MacOS

Add LSTAT_NAME for MacOS


-----------------------------------------------------------------------
--  asf-navigations-render -- Navigator to render a page
--  Copyright (C) 2010, 2011, 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.Exceptions;
with Util.Log.Loggers;
with ASF.Components.Root;

package body ASF.Navigations.Render is

   use Ada.Exceptions;
   use ASF.Applications;

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("ASF.Navigations.Render");

   --  ------------------------------
   --  Navigate to the next page or action according to the controller's navigator.
   --  A navigator controller could redirect the user to another page, render a specific
   --  view or return some raw content.
   --  ------------------------------
   overriding
   procedure Navigate (Controller : in Render_Navigator;
                       Context    : in out ASF.Contexts.Faces.Faces_Context'Class) is
      View : Components.Root.UIViewRoot;
   begin
      Log.Debug ("Navigate to view {0}", Controller.View_Name);

      if Controller.Status /= 0 then
         Context.Get_Response.Set_Status (Controller.Status);
      end if;
      Controller.View_Handler.Create_View (Controller.View_Name, Context, View);

      Context.Set_View_Root (View);

   exception
      when E : others =>
         Log.Error ("Error when navigating to view {0}: {1}: {2}", Controller.View_Name,
                    Exception_Name (E), Exception_Message (E));
         raise;

   end Navigate;

   --  ------------------------------
   --  Create a navigation case to render a view.
   --  ------------------------------
   function Create_Render_Navigator (To_View : in String;
                                     Status  : in Natural) return Navigation_Access is
      Result : constant Render_Navigator_Access
        := new Render_Navigator '(Len       => To_View'Length,
                                  Status    => Status,
                                  View_Name => To_View,
                                  others    => <>);
   begin
      return Result.all'Access;
   end Create_Render_Navigator;

end ASF.Navigations.Render;

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

package body ASF.Navigations.Render is

   use Ada.Exceptions;

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("ASF.Navigations.Render");

   --  ------------------------------
   --  Navigate to the next page or action according to the controller's navigator.
   --  A navigator controller could redirect the user to another page, render a specific
   --  view or return some raw content.
   --  ------------------------------
   overriding
   procedure Navigate (Controller : in Render_Navigator;
                       Context    : in out ASF.Contexts.Faces.Faces_Context'Class) is
      View : Components.Root.UIViewRoot;
   begin
      Log.Debug ("Navigate to view {0}", Controller.View_Name);

      if Controller.Status /= 0 then
         Context.Get_Response.Set_Status (Controller.Status);
      end if;
      Controller.View_Handler.Create_View (Controller.View_Name, Context, View);

      Context.Set_View_Root (View);

   exception
      when E : others =>
         Log.Error ("Error when navigating to view {0}: {1}: {2}", Controller.View_Name,
                    Exception_Name (E), Exception_Message (E));
         raise;

   end Navigate;

   --  ------------------------------
   --  Create a navigation case to render a view.
   --  ------------------------------
   function Create_Render_Navigator (To_View : in String;
                                     Status  : in Natural) return Navigation_Access is
      Result : constant Render_Navigator_Access
        := new Render_Navigator '(Len       => To_View'Length,
                                  Status    => Status,
                                  View_Name => To_View,
                                  others    => <>);
   begin
      return Result.all'Access;
   end Create_Render_Navigator;

end ASF.Navigations.Render;

Remove unused use clauses

Remove unused use clauses


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

with Ada.Text_IO;
with Ada.Directories;
with Ada.Characters.Conversions;

with Util.Files;
with Util.Measures;

with Wiki.Render.Wiki;
with Wiki.Filters.Html;
with Wiki.Writers.Builders;
with Wiki.Utils;
package body Wiki.Writers.Tests is

   use Ada.Strings.Unbounded;
   use type Wiki.Parsers.Wiki_Syntax_Type;

   --  ------------------------------
   --  Test rendering a wiki text in HTML or text.
   --  ------------------------------
   procedure Test_Render (T : in out Test) is
      function To_Wide (Item : in String) return Wide_Wide_String
        renames Ada.Characters.Conversions.To_Wide_Wide_String;

      Result_File : constant String := To_String (T.Result);
      Content     : Unbounded_String;
   begin
      Util.Files.Read_File (Path     => To_String (T.File),
                            Into     => Content,
                            Max_Size => 10000);
      declare
         Time : Util.Measures.Stamp;
      begin
         if T.Source = Wiki.Parsers.SYNTAX_HTML then
            declare
               Html_Filter : aliased Wiki.Filters.Html.Html_Filter_Type;
               Writer      : aliased Wiki.Writers.Builders.Writer_Builder_Type;
               Renderer    : aliased Wiki.Render.Wiki.Wiki_Renderer;
            begin
               Renderer.Set_Writer (Writer'Unchecked_Access, T.Format);
               Html_Filter.Set_Document (Renderer'Unchecked_Access);
               Wiki.Parsers.Parse (Html_Filter'Unchecked_Access, To_Wide (To_String (Content)),
                                   Wiki.Parsers.SYNTAX_HTML);
               Content := To_Unbounded_String (Writer.To_String);
            end;
         elsif T.Is_Html then
            Content := To_Unbounded_String
              (Utils.To_Html (To_Wide (To_String (Content)), T.Format));
         else
            Content := To_Unbounded_String
              (Utils.To_Text (To_Wide (To_String (Content)), T.Format));
         end if;

         Util.Measures.Report (Time, "Render " & To_String (T.Name));
      end;

      Util.Files.Write_File (Result_File, Content);
      Util.Tests.Assert_Equal_Files (T       => T,
                                     Expect  => To_String (T.Expect),
                                     Test    => Result_File,
                                     Message => "Render");
   end Test_Render;

   --  ------------------------------
   --  Test case name
   --  ------------------------------
   overriding
   function Name (T : in Test) return Util.Tests.Message_String is
   begin
      if T.Source = Wiki.Parsers.SYNTAX_HTML then
         return Util.Tests.Format ("Test IMPORT " & To_String (T.Name));
      elsif T.Is_Html then
         return Util.Tests.Format ("Test HTML " & To_String (T.Name));
      else
         return Util.Tests.Format ("Test TEXT " & To_String (T.Name));
      end if;
   end Name;

   --  ------------------------------
   --  Perform the test.
   --  ------------------------------
   overriding
   procedure Run_Test (T : in out Test) is
   begin
      T.Test_Render;
   end Run_Test;

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
      use Ada.Directories;
      function Create_Test (Name    : in String;
                            Path    : in String;
                            Format  : in Wiki.Parsers.Wiki_Syntax_Type;
                            Prefix  : in String;
                            Is_Html : in Boolean) return Test_Case_Access;

      Result_Dir  : constant String := "regtests/result";
      Expect_Dir  : constant String := "regtests/expect";
      Expect_Path : constant String := Util.Tests.Get_Path (Expect_Dir);
      Result_Path : constant String := Util.Tests.Get_Test_Path (Result_Dir);
      Search      : Search_Type;
      Filter      : constant Filter_Type := (others => True);
      Ent         : Directory_Entry_Type;

      function Create_Test (Name    : in String;
                            Path    : in String;
                            Format  : in Wiki.Parsers.Wiki_Syntax_Type;
                            Prefix  : in String;
                            Is_Html : in Boolean) return Test_Case_Access is
         Tst    : Test_Case_Access;
      begin
         Tst := new Test;
         Tst.Is_Html := Is_Html;
         Tst.Name    := To_Unbounded_String (Name);
         Tst.File    := To_Unbounded_String (Path);
         Tst.Expect  := To_Unbounded_String (Expect_Path & Prefix & Name);
         Tst.Result  := To_Unbounded_String (Result_Path & Prefix & Name);
         Tst.Format  := Format;
         Tst.Source  := Format;
         return Tst;
      end Create_Test;

      procedure Add_Wiki_Tests is
         Dir         : constant String := "regtests/files/wiki";
         Path        : constant String := Util.Tests.Get_Path (Dir);
      begin
         if Kind (Path) /= Directory then
            Ada.Text_IO.Put_Line ("Cannot read test directory: " & Path);
         end if;

         Start_Search (Search, Directory => Path, Pattern => "*.*", Filter => Filter);
         while More_Entries (Search) loop
            Get_Next_Entry (Search, Ent);
            declare
               Simple : constant String := Simple_Name (Ent);
               Ext    : constant String := Ada.Directories.Extension (Simple);
               Tst    : Test_Case_Access;
               Format : Wiki.Parsers.Wiki_Syntax_Type;
            begin
               if Simple /= "." and then Simple /= ".."
                 and then Simple /= ".svn" and then Simple (Simple'Last) /= '~'
               then
                  if Ext = "wiki" then
                     Format := Wiki.Parsers.SYNTAX_GOOGLE;
                  elsif Ext = "dotclear" then
                     Format := Wiki.Parsers.SYNTAX_DOTCLEAR;
                  elsif Ext = "creole" then
                     Format := Wiki.Parsers.SYNTAX_CREOLE;
                  elsif Ext = "phpbb" then
                     Format := Wiki.Parsers.SYNTAX_PHPBB;
                  elsif Ext = "mediawiki" then
                     Format := Wiki.Parsers.SYNTAX_MEDIA_WIKI;
                  else
                     Format := Wiki.Parsers.SYNTAX_MIX;
                  end if;

                  Tst := Create_Test (Simple, Path & "/" & Simple, Format, "/wiki-html/", True);
                  Suite.Add_Test (Tst.all'Access);

                  Tst := Create_Test (Simple, Path & "/" & Simple, Format, "/wiki-txt/", False);
                  Suite.Add_Test (Tst.all'Access);
               end if;
            end;
         end loop;
      end Add_Wiki_Tests;

      procedure Add_Import_Tests is
         Dir         : constant String := "regtests/files/html";
         Path        : constant String := Util.Tests.Get_Path (Dir);
      begin
         if Kind (Path) /= Directory then
            Ada.Text_IO.Put_Line ("Cannot read test directory: " & Path);
         end if;

         Start_Search (Search, Directory => Path, Pattern => "*.*", Filter => Filter);
         while More_Entries (Search) loop
            Get_Next_Entry (Search, Ent);
            declare
               Simple : constant String := Simple_Name (Ent);
               Name   : constant String := Base_Name (Simple);
               Tst    : Test_Case_Access;
            begin
               if Simple /= "." and then Simple /= ".."
                 and then Simple /= ".svn" and then Simple (Simple'Last) /= '~'
               then
                  for Syntax in Wiki.Parsers.Wiki_Syntax_Type'Range loop
                     case Syntax is
                        when Wiki.Parsers.SYNTAX_CREOLE =>
                           Tst := Create_Test (Name & ".creole", Path & "/" & Simple,
                                               Syntax, "/wiki-import/", True);

                        when Wiki.Parsers.SYNTAX_MEDIA_WIKI =>
                           Tst := Create_Test (Name & ".mediawiki", Path & "/" & Simple,
                                               Syntax, "/wiki-import/", True);

                        when others =>
                           Tst := null;

                     end case;
                     if Tst /= null then
                        Tst.Source := Wiki.Parsers.SYNTAX_HTML;
                        Suite.Add_Test (Tst.all'Access);
                     end if;
                  end loop;
               end if;
            end;
         end loop;
      end Add_Import_Tests;

   begin
      Add_Wiki_Tests;
      Add_Import_Tests;
   end Add_Tests;

end Wiki.Writers.Tests;

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

with Ada.Text_IO;
with Ada.Directories;
with Ada.Characters.Conversions;

with Util.Files;
with Util.Measures;

with Wiki.Render.Wiki;
with Wiki.Filters.Html;
with Wiki.Writers.Builders;
with Wiki.Utils;
package body Wiki.Writers.Tests is

   use Ada.Strings.Unbounded;
   use type Wiki.Parsers.Wiki_Syntax_Type;

   --  ------------------------------
   --  Test rendering a wiki text in HTML or text.
   --  ------------------------------
   procedure Test_Render (T : in out Test) is
      function To_Wide (Item : in String) return Wide_Wide_String
        renames Ada.Characters.Conversions.To_Wide_Wide_String;

      Result_File : constant String := To_String (T.Result);
      Content     : Unbounded_String;
   begin
      Util.Files.Read_File (Path     => To_String (T.File),
                            Into     => Content,
                            Max_Size => 10000);
      declare
         Time : Util.Measures.Stamp;
      begin
         if T.Source = Wiki.Parsers.SYNTAX_HTML then
            declare
               Html_Filter : aliased Wiki.Filters.Html.Html_Filter_Type;
               Writer      : aliased Wiki.Writers.Builders.Writer_Builder_Type;
               Renderer    : aliased Wiki.Render.Wiki.Wiki_Renderer;
            begin
               Renderer.Set_Writer (Writer'Unchecked_Access, T.Format);
               Html_Filter.Set_Document (Renderer'Unchecked_Access);
               Wiki.Parsers.Parse (Html_Filter'Unchecked_Access, To_Wide (To_String (Content)),
                                   Wiki.Parsers.SYNTAX_HTML);
               Content := To_Unbounded_String (Writer.To_String);
            end;
         elsif T.Is_Html then
            Content := To_Unbounded_String
              (Utils.To_Html (To_Wide (To_String (Content)), T.Format));
         else
            Content := To_Unbounded_String
              (Utils.To_Text (To_Wide (To_String (Content)), T.Format));
         end if;

         Util.Measures.Report (Time, "Render " & To_String (T.Name));
      end;

      Util.Files.Write_File (Result_File, Content);
      Util.Tests.Assert_Equal_Files (T       => T,
                                     Expect  => To_String (T.Expect),
                                     Test    => Result_File,
                                     Message => "Render");
   end Test_Render;

   --  ------------------------------
   --  Test case name
   --  ------------------------------
   overriding
   function Name (T : in Test) return Util.Tests.Message_String is
   begin
      if T.Source = Wiki.Parsers.SYNTAX_HTML then
         return Util.Tests.Format ("Test IMPORT " & To_String (T.Name));
      elsif T.Is_Html then
         return Util.Tests.Format ("Test HTML " & To_String (T.Name));
      else
         return Util.Tests.Format ("Test TEXT " & To_String (T.Name));
      end if;
   end Name;

   --  ------------------------------
   --  Perform the test.
   --  ------------------------------
   overriding
   procedure Run_Test (T : in out Test) is
   begin
      T.Test_Render;
   end Run_Test;

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
      use Ada.Directories;
      function Create_Test (Name    : in String;
                            Path    : in String;
                            Format  : in Wiki.Parsers.Wiki_Syntax_Type;
                            Prefix  : in String;
                            Is_Html : in Boolean) return Test_Case_Access;

      Result_Dir  : constant String := "regtests/result";
      Expect_Dir  : constant String := "regtests/expect";
      Expect_Path : constant String := Util.Tests.Get_Path (Expect_Dir);
      Result_Path : constant String := Util.Tests.Get_Test_Path (Result_Dir);
      Search      : Search_Type;
      Filter      : constant Filter_Type := (others => True);
      Ent         : Directory_Entry_Type;

      function Create_Test (Name    : in String;
                            Path    : in String;
                            Format  : in Wiki.Parsers.Wiki_Syntax_Type;
                            Prefix  : in String;
                            Is_Html : in Boolean) return Test_Case_Access is
         Tst    : Test_Case_Access;
      begin
         Tst := new Test;
         Tst.Is_Html := Is_Html;
         Tst.Name    := To_Unbounded_String (Name);
         Tst.File    := To_Unbounded_String (Path);
         Tst.Expect  := To_Unbounded_String (Expect_Path & Prefix & Name);
         Tst.Result  := To_Unbounded_String (Result_Path & Prefix & Name);
         Tst.Format  := Format;
         Tst.Source  := Format;
         return Tst;
      end Create_Test;

      procedure Add_Wiki_Tests is
         Dir         : constant String := "regtests/files/wiki";
         Path        : constant String := Util.Tests.Get_Path (Dir);
      begin
         if Kind (Path) /= Directory then
            Ada.Text_IO.Put_Line ("Cannot read test directory: " & Path);
         end if;

         Start_Search (Search, Directory => Path, Pattern => "*.*", Filter => Filter);
         while More_Entries (Search) loop
            Get_Next_Entry (Search, Ent);
            declare
               Simple : constant String := Simple_Name (Ent);
               Ext    : constant String := Ada.Directories.Extension (Simple);
               Tst    : Test_Case_Access;
               Format : Wiki.Parsers.Wiki_Syntax_Type;
            begin
               if Simple /= "." and then Simple /= ".."
                 and then Simple /= ".svn" and then Simple (Simple'Last) /= '~'
               then
                  if Ext = "wiki" then
                     Format := Wiki.Parsers.SYNTAX_GOOGLE;
                  elsif Ext = "dotclear" then
                     Format := Wiki.Parsers.SYNTAX_DOTCLEAR;
                  elsif Ext = "creole" then
                     Format := Wiki.Parsers.SYNTAX_CREOLE;
                  elsif Ext = "phpbb" then
                     Format := Wiki.Parsers.SYNTAX_PHPBB;
                  elsif Ext = "mediawiki" then
                     Format := Wiki.Parsers.SYNTAX_MEDIA_WIKI;
                  else
                     Format := Wiki.Parsers.SYNTAX_MIX;
                  end if;

                  Tst := Create_Test (Simple, Path & "/" & Simple, Format, "/wiki-html/", True);
                  Suite.Add_Test (Tst.all'Access);

                  Tst := Create_Test (Simple, Path & "/" & Simple, Format, "/wiki-txt/", False);
                  Suite.Add_Test (Tst.all'Access);
               end if;
            end;
         end loop;
      end Add_Wiki_Tests;

      procedure Add_Import_Tests is
         Dir         : constant String := "regtests/files/html";
         Path        : constant String := Util.Tests.Get_Path (Dir);
      begin
         if Kind (Path) /= Directory then
            Ada.Text_IO.Put_Line ("Cannot read test directory: " & Path);
         end if;

         Start_Search (Search, Directory => Path, Pattern => "*.*", Filter => Filter);
         while More_Entries (Search) loop
            Get_Next_Entry (Search, Ent);
            declare
               Simple : constant String := Simple_Name (Ent);
               Name   : constant String := Base_Name (Simple);
               Tst    : Test_Case_Access;
            begin
               if Simple /= "." and then Simple /= ".."
                 and then Simple /= ".svn" and then Simple (Simple'Last) /= '~'
               then
                  for Syntax in Wiki.Parsers.Wiki_Syntax_Type'Range loop
                     case Syntax is
                        when Wiki.Parsers.SYNTAX_CREOLE =>
                           Tst := Create_Test (Name & ".creole", Path & "/" & Simple,
                                               Syntax, "/wiki-import/", True);

                        when Wiki.Parsers.SYNTAX_DOTCLEAR =>
                           Tst := Create_Test (Name & ".dotclear", Path & "/" & Simple,
                                               Syntax, "/wiki-import/", True);

                        when others =>
                           Tst := null;

                     end case;
                     if Tst /= null then
                        Tst.Source := Wiki.Parsers.SYNTAX_HTML;
                        Suite.Add_Test (Tst.all'Access);
                     end if;
                  end loop;
               end if;
            end;
         end loop;
      end Add_Import_Tests;

   begin
      Add_Wiki_Tests;
      Add_Import_Tests;
   end Add_Tests;

end Wiki.Writers.Tests;

Update the import test for the Dotclear syntax import


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

with Ada.Unchecked_Deallocation;
package body Util.Http.Clients is

   --  ------------------------------
   --  Returns a boolean indicating whether the named response header has already
   --  been set.
   --  ------------------------------
   overriding
   function Contains_Header (Reply : in Response;
                             Name  : in String) return Boolean is
   begin
      if Reply.Delegate = null then
         return False;
      else
         return Reply.Delegate.Contains_Header (Name);
      end if;
   end Contains_Header;

   --  ------------------------------
   --  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 Response;
                        Name   : in String) return String is
   begin
      if Reply.Delegate = null then
         return "";
      else
         return Reply.Delegate.Get_Header (Name);
      end if;
   end Get_Header;

   --  ------------------------------
   --  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 Response;
                         Name     : in String;
                         Value    : in String) is
   begin
      if Reply.Delegate = null then
         null;
      end if;
      Reply.Delegate.Set_Header (Name, Value);
   end Set_Header;

   --  ------------------------------
   --  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 Response;
                         Name    : in String;
                         Value   : in String) is
   begin
      Reply.Delegate.Add_Header (Name, Value);
   end Add_Header;

   --  ------------------------------
   --  Iterate over the response headers and executes the Process procedure.
   --  ------------------------------
   overriding
   procedure Iterate_Headers (Reply   : in Response;
                              Process : not null access
                                procedure (Name  : in String;
                                           Value : in String)) is
   begin
      if Reply.Delegate /= null then
         Reply.Delegate.Iterate_Headers (Process);
      end if;
   end Iterate_Headers;

   --  ------------------------------
   --  Get the response body as a string.
   --  ------------------------------
   overriding
   function Get_Body (Reply : in Response) return String is
   begin
      if Reply.Delegate = null then
         return "";
      else
         return Reply.Delegate.Get_Body;
      end if;
   end Get_Body;

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

   --  ------------------------------
   --  Returns a boolean indicating whether the named response header has already
   --  been set.
   --  ------------------------------
   overriding
   function Contains_Header (Request : in Client;
                             Name    : in String) return Boolean is
   begin
      return Request.Delegate.Contains_Header (Name);
   end Contains_Header;

   --  ------------------------------
   --  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 Client;
                        Name    : in String) return String is
   begin
      return Request.Delegate.Get_Header (Name);
   end Get_Header;

   --  ------------------------------
   --  Sets a 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 (Request  : in out Client;
                         Name     : in String;
                         Value    : in String) is
   begin
      Request.Delegate.Set_Header (Name, Value);
   end Set_Header;

   --  ------------------------------
   --  Adds a header with the given name and value.
   --  This method allows headers to have multiple values.
   --  ------------------------------
   overriding
   procedure Add_Header (Request  : in out Client;
                         Name     : in String;
                         Value    : in String) is
   begin
      Request.Delegate.Add_Header (Name, Value);
   end Add_Header;

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

   --  ------------------------------
   --  Removes all headers with the given name.
   --  ------------------------------
   procedure Remove_Header (Request : in out Client;
                            Name    : in String) is
   begin
      null;
   end Remove_Header;

   --  ------------------------------
   --  Initialize the client
   --  ------------------------------
   overriding
   procedure Initialize (Http : in out Client) is
   begin
      Http.Delegate := null;
      Http.Manager  := Default_Http_Manager;
      Http.Manager.Create (Http);
   end Initialize;

   overriding
   procedure Finalize (Http : in out Client) is
      procedure Free is new Ada.Unchecked_Deallocation (Http_Request'Class,
                                                        Http_Request_Access);
   begin
      Free (Http.Delegate);
   end Finalize;

   --  ------------------------------
   --  Execute an http GET request on the given URL.  Additional request parameters,
   --  cookies and headers should have been set on the client object.
   --  ------------------------------
   procedure Get (Request  : in out Client;
                  URL      : in String;
                  Reply    : out Response'Class) is
   begin
      Request.Manager.Do_Get (Request, URL, Reply);
   end Get;

   --  ------------------------------
   --  Execute an http POST request on the given URL.  The post data is passed in Data.
   --  Additional request cookies and headers should have been set on the client object.
   --  ------------------------------
   procedure Post (Request : in out Client;
                   URL     : in String;
                   Data    : in String;
                   Reply   : out Response'Class) is
   begin
      Request.Manager.Do_Post (Request, URL, Data, Reply);
   end Post;

   --  ------------------------------
   --  Adds the specified cookie to the request. This method can be called multiple
   --  times to set more than one cookie.
   --  ------------------------------
   procedure Add_Cookie (Http   : in out Client;
                         Cookie : in Util.Http.Cookies.Cookie) is
   begin
      null;
   end Add_Cookie;

   --  ------------------------------
   --  Free the resource used by the response.
   --  ------------------------------
   overriding
   procedure Finalize (Reply : in out Response) is
      procedure Free is new Ada.Unchecked_Deallocation (Http_Response'Class,
                                                        Http_Response_Access);
   begin
      Free (Reply.Delegate);
   end Finalize;

end Util.Http.Clients;

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

with Ada.Unchecked_Deallocation;
package body Util.Http.Clients is

   --  ------------------------------
   --  Returns a boolean indicating whether the named response header has already
   --  been set.
   --  ------------------------------
   overriding
   function Contains_Header (Reply : in Response;
                             Name  : in String) return Boolean is
   begin
      if Reply.Delegate = null then
         return False;
      else
         return Reply.Delegate.Contains_Header (Name);
      end if;
   end Contains_Header;

   --  ------------------------------
   --  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 Response;
                        Name   : in String) return String is
   begin
      if Reply.Delegate = null then
         return "";
      else
         return Reply.Delegate.Get_Header (Name);
      end if;
   end Get_Header;

   --  ------------------------------
   --  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 Response;
                         Name     : in String;
                         Value    : in String) is
   begin
      Reply.Delegate.Set_Header (Name, Value);
   end Set_Header;

   --  ------------------------------
   --  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 Response;
                         Name    : in String;
                         Value   : in String) is
   begin
      Reply.Delegate.Add_Header (Name, Value);
   end Add_Header;

   --  ------------------------------
   --  Iterate over the response headers and executes the Process procedure.
   --  ------------------------------
   overriding
   procedure Iterate_Headers (Reply   : in Response;
                              Process : not null access
                                procedure (Name  : in String;
                                           Value : in String)) is
   begin
      if Reply.Delegate /= null then
         Reply.Delegate.Iterate_Headers (Process);
      end if;
   end Iterate_Headers;

   --  ------------------------------
   --  Get the response body as a string.
   --  ------------------------------
   overriding
   function Get_Body (Reply : in Response) return String is
   begin
      if Reply.Delegate = null then
         return "";
      else
         return Reply.Delegate.Get_Body;
      end if;
   end Get_Body;

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

   --  ------------------------------
   --  Returns a boolean indicating whether the named response header has already
   --  been set.
   --  ------------------------------
   overriding
   function Contains_Header (Request : in Client;
                             Name    : in String) return Boolean is
   begin
      if Request.Delegate = null then
         return False;
      else
         return Request.Delegate.Contains_Header (Name);
      end if;
   end Contains_Header;

   --  ------------------------------
   --  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 Client;
                        Name    : in String) return String is
   begin
      if Request.Delegate = null then
         return "";
      else
         return Request.Delegate.Get_Header (Name);
      end if;
   end Get_Header;

   --  ------------------------------
   --  Sets a 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 (Request  : in out Client;
                         Name     : in String;
                         Value    : in String) is
   begin
      Request.Delegate.Set_Header (Name, Value);
   end Set_Header;

   --  ------------------------------
   --  Adds a header with the given name and value.
   --  This method allows headers to have multiple values.
   --  ------------------------------
   overriding
   procedure Add_Header (Request  : in out Client;
                         Name     : in String;
                         Value    : in String) is
   begin
      Request.Delegate.Add_Header (Name, Value);
   end Add_Header;

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

   --  ------------------------------
   --  Removes all headers with the given name.
   --  ------------------------------
   procedure Remove_Header (Request : in out Client;
                            Name    : in String) is
   begin
      null;
   end Remove_Header;

   --  ------------------------------
   --  Initialize the client
   --  ------------------------------
   overriding
   procedure Initialize (Http : in out Client) is
   begin
      Http.Delegate := null;
      Http.Manager  := Default_Http_Manager;
      Http.Manager.Create (Http);
   end Initialize;

   overriding
   procedure Finalize (Http : in out Client) is
      procedure Free is new Ada.Unchecked_Deallocation (Http_Request'Class,
                                                        Http_Request_Access);
   begin
      Free (Http.Delegate);
   end Finalize;

   --  ------------------------------
   --  Execute an http GET request on the given URL.  Additional request parameters,
   --  cookies and headers should have been set on the client object.
   --  ------------------------------
   procedure Get (Request  : in out Client;
                  URL      : in String;
                  Reply    : out Response'Class) is
   begin
      Request.Manager.Do_Get (Request, URL, Reply);
   end Get;

   --  ------------------------------
   --  Execute an http POST request on the given URL.  The post data is passed in Data.
   --  Additional request cookies and headers should have been set on the client object.
   --  ------------------------------
   procedure Post (Request : in out Client;
                   URL     : in String;
                   Data    : in String;
                   Reply   : out Response'Class) is
   begin
      Request.Manager.Do_Post (Request, URL, Data, Reply);
   end Post;

   --  ------------------------------
   --  Adds the specified cookie to the request. This method can be called multiple
   --  times to set more than one cookie.
   --  ------------------------------
   procedure Add_Cookie (Http   : in out Client;
                         Cookie : in Util.Http.Cookies.Cookie) is
   begin
      null;
   end Add_Cookie;

   --  ------------------------------
   --  Free the resource used by the response.
   --  ------------------------------
   overriding
   procedure Finalize (Reply : in out Response) is
      procedure Free is new Ada.Unchecked_Deallocation (Http_Response'Class,
                                                        Http_Response_Access);
   begin
      Free (Reply.Delegate);
   end Finalize;

end Util.Http.Clients;

Check that the delegate instance is not null


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

   --  ------------------------------
   --  Find in the list the first event with the given type.
   --  Raise <tt>Not_Found</tt> if the list does not contain such event.
   --  ------------------------------
   function Find (List : in Target_Event_Vector;
                  Kind : in Probe_Index_Type) return Target_Event_Type is
      Iter  : Target_Event_Cursor := List.First;
      Event : Target_Event_Type;
   begin
      while Target_Event_Vectors.Has_Element (Iter) loop
         Event := Target_Event_Vectors.Element (Iter);
         if Event.Index = Kind then
            return Event;
         end if;
         Target_Event_Vectors.Next (Iter);
      end loop;
      raise Not_Found;
   end Find;

   function "<" (Left, Right : in Frame_Key_Type) return Boolean is
   begin
      if Left.Addr < Right.Addr then
         return True;
      elsif Left.Addr > Right.Addr then
         return False;
      else
         return Left.Level < Right.Level;
      end if;
   end "<";

   --  ------------------------------
   --  Extract from the frame info map, the list of event info sorted on the count.
   --  ------------------------------
   procedure Build_Event_Info (Map  : in Frame_Event_Info_Map;
                               List : in out Event_Info_Vector) is

      function "<" (Left, Right : in Event_Info_Type) return Boolean is
      begin
         return Left.Count < Right.Count;
      end "<";

      package Sort_Event_Info is new Event_Info_Vectors.Generic_Sorting;
      Iter : Frame_Event_Info_Cursor := Map.First;
      Item : Event_Info_Type;
   begin
      while Frame_Event_Info_Maps.Has_Element (Iter) loop
         Item := Frame_Event_Info_Maps.Element (Iter);
         List.Append (Item);
         Frame_Event_Info_Maps.Next (Iter);
      end loop;
      Sort_Event_Info.Sort (List);
   end Build_Event_Info;

end MAT.Events.Tools;

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

   --  ------------------------------
   --  Find in the list the first event with the given type.
   --  Raise <tt>Not_Found</tt> if the list does not contain such event.
   --  ------------------------------
   function Find (List : in Target_Event_Vector;
                  Kind : in Probe_Index_Type) return Target_Event_Type is
      Iter  : Target_Event_Cursor := List.First;
      Event : Target_Event_Type;
   begin
      while Target_Event_Vectors.Has_Element (Iter) loop
         Event := Target_Event_Vectors.Element (Iter);
         if Event.Index = Kind then
            return Event;
         end if;
         Target_Event_Vectors.Next (Iter);
      end loop;
      raise Not_Found;
   end Find;

   function "<" (Left, Right : in Frame_Key_Type) return Boolean is
   begin
      if Left.Addr < Right.Addr then
         return True;
      elsif Left.Addr > Right.Addr then
         return False;
      else
         return Left.Level < Right.Level;
      end if;
   end "<";

   --  ------------------------------
   --  Extract from the frame info map, the list of event info sorted on the count.
   --  ------------------------------
   procedure Build_Event_Info (Map  : in Frame_Event_Info_Map;
                               List : in out Event_Info_Vector) is

      function "<" (Left, Right : in Event_Info_Type) return Boolean is
      begin
         return Left.Count < Right.Count;
      end "<";

      package Sort_Event_Info is new Event_Info_Vectors.Generic_Sorting;
      Iter : Frame_Event_Info_Cursor := Map.First;
      Item : Event_Info_Type;
   begin
      while Frame_Event_Info_Maps.Has_Element (Iter) loop
         Item := Frame_Event_Info_Maps.Element (Iter);
         List.Append (Item);
         Frame_Event_Info_Maps.Next (Iter);
      end loop;
      Sort_Event_Info.Sort (List);
   end Build_Event_Info;

   --  ------------------------------
   --  Extract from the frame info map, the list of frame event info sorted
   --  on the frame level and slot size.
   --  ------------------------------
   procedure Build_Frame_Info (Map  : in Frame_Event_Info_Map;
                               List : in out Frame_Info_Vector) is

      function "<" (Left, Right : in Frame_Info_Type) return Boolean;

      function "<" (Left, Right : in Frame_Info_Type) return Boolean is
      begin
         if Left.Key.Level < Right.Key.Level then
            return True;
         else
            return False;
         end if;
      end "<";

      package Sort_Frame_Info is new Frame_Info_Vectors.Generic_Sorting;

      Iter : Frame_Event_Info_Cursor := Map.First;
      Item : Frame_Info_Type;
   begin
      while Frame_Event_Info_Maps.Has_Element (Iter) loop
         Item.Key  := Frame_Event_Info_Maps.Key (Iter);
         Item.Info := Frame_Event_Info_Maps.Element (Iter);
         List.Append (Item);
         Frame_Event_Info_Maps.Next (Iter);
      end loop;
      Sort_Frame_Info.Sort (List);
   end Build_Frame_Info;

end MAT.Events.Tools;

Implement Build_Frame_Info to collect the frame data and sort them


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

with Ada.Finalization;

with ADO.Statements;
with ADO.Schemas;
with Util.Properties;
with Util.Strings;

--  The <b>ADO.Drivers</b> package represents the database driver that will create
--  database connections and provide the database specific implementation.
package ADO.Drivers.Connections is

   use ADO.Statements;

   type Driver is abstract tagged limited private;
   type Driver_Access is access all Driver'Class;

   --  ------------------------------
   --  Database connection implementation
   --  ------------------------------
   --
   type Database_Connection is abstract new Ada.Finalization.Limited_Controlled with record
      Count : Natural := 0;
      Ident : String (1 .. 8) := (others => ' ');
   end record;
   type Database_Connection_Access is access all Database_Connection'Class;

   function Create_Statement (Database : in Database_Connection;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Query_Statement_Access is abstract;

   function Create_Statement (Database : in Database_Connection;
                              Query    : in String)
                              return Query_Statement_Access is abstract;

   --  Create a delete statement.
   function Create_Statement (Database : in Database_Connection;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Delete_Statement_Access is abstract;

   --  Create an insert statement.
   function Create_Statement (Database : in Database_Connection;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Insert_Statement_Access is abstract;

   --  Create an update statement.
   function Create_Statement (Database : in Database_Connection;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Update_Statement_Access is abstract;

   --  Start a transaction.
   procedure Begin_Transaction (Database : in out Database_Connection) is abstract;

   --  Commit the current transaction.
   procedure Commit (Database : in out Database_Connection) is abstract;

   --  Rollback the current transaction.
   procedure Rollback (Database : in out Database_Connection) is abstract;

   --  Load the database schema definition for the current database.
   procedure Load_Schema (Database : in Database_Connection;
                          Schema   : out ADO.Schemas.Schema_Definition) is abstract;

   --  Get the database driver which manages this connection.
   function Get_Driver (Database : in Database_Connection)
                        return Driver_Access is abstract;

   --  Closes the database connection
   procedure Close (Database : in out Database_Connection) is abstract;

   --  ------------------------------
   --  The database configuration properties
   --  ------------------------------
   type Configuration is new Ada.Finalization.Controlled with private;
   type Configuration_Access is access all Configuration'Class;

   --  Set the connection URL to connect to the database.
   --  The driver connection is a string of the form:
   --
   --   driver://[host][:port]/[database][?property1][=value1]...
   --
   --  If the string is invalid or if the driver cannot be found,
   --  the Connection_Error exception is raised.
   procedure Set_Connection (Controller : in out Configuration;
                             URI        : in String);

   --  Set a property on the datasource for the driver.
   --  The driver can retrieve the property to configure and open
   --  the database connection.
   procedure Set_Property (Controller : in out Configuration;
                           Name       : in String;
                           Value      : in String);

   --  Get a property from the data source configuration.
   --  If the property does not exist, an empty string is returned.
   function Get_Property (Controller : in Configuration;
                          Name       : in String) return String;

   --  Set the server hostname.
   procedure Set_Server (Controller : in out Configuration;
                         Server     : in String);

   --  Get the server hostname.
   function Get_Server (Controller : in Configuration) return String;

   --  Get the server port.
   function Get_Port (Controller : in Configuration) return Integer;

   --  Get the database name.
   function Get_Database (Controller : in Configuration) return String;

   --  Create a new connection using the configuration parameters.
   procedure Create_Connection (Config : in Configuration'Class;
                                Result : out Database_Connection_Access);

   --  ------------------------------
   --  Database Driver
   --  ------------------------------

   --  Create a new connection using the configuration parameters.
   procedure Create_Connection (D      : in out Driver;
                                Config : in Configuration'Class;
                                Result : out Database_Connection_Access) is abstract;

   --  Get the driver unique index.
   function Get_Driver_Index (D : in Driver) return Driver_Index;

   --  Get the driver name.
   function Get_Driver_Name (D : in Driver) return String;

   --  Register a database driver.
   procedure Register (Driver : in Driver_Access);

   --  Get a database driver given its name.
   function Get_Driver (Name : in String) return Driver_Access;

private

   type Driver is abstract new Ada.Finalization.Limited_Controlled with record
      Name  : Util.Strings.Name_Access;
      Index : Driver_Index;
   end record;

   type Configuration is new Ada.Finalization.Controlled with record
      URI        : Unbounded_String := Null_Unbounded_String;
      Server     : Unbounded_String := Null_Unbounded_String;
      Port       : Integer := 0;
      Database   : Unbounded_String := Null_Unbounded_String;
      Properties : Util.Properties.Manager;
      Driver     : Driver_Access;
   end record;

end ADO.Drivers.Connections;

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

with Ada.Finalization;

with ADO.Statements;
with ADO.Schemas;
with Util.Properties;
with Util.Strings;

--  The <b>ADO.Drivers</b> package represents the database driver that will create
--  database connections and provide the database specific implementation.
package ADO.Drivers.Connections is

   use ADO.Statements;

   type Driver is abstract tagged limited private;
   type Driver_Access is access all Driver'Class;

   --  ------------------------------
   --  Database connection implementation
   --  ------------------------------
   --
   type Database_Connection is abstract new Ada.Finalization.Limited_Controlled with record
      Count : Natural := 0;
      Ident : String (1 .. 8) := (others => ' ');
   end record;
   type Database_Connection_Access is access all Database_Connection'Class;

   function Create_Statement (Database : in Database_Connection;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Query_Statement_Access is abstract;

   function Create_Statement (Database : in Database_Connection;
                              Query    : in String)
                              return Query_Statement_Access is abstract;

   --  Create a delete statement.
   function Create_Statement (Database : in Database_Connection;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Delete_Statement_Access is abstract;

   --  Create an insert statement.
   function Create_Statement (Database : in Database_Connection;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Insert_Statement_Access is abstract;

   --  Create an update statement.
   function Create_Statement (Database : in Database_Connection;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Update_Statement_Access is abstract;

   --  Start a transaction.
   procedure Begin_Transaction (Database : in out Database_Connection) is abstract;

   --  Commit the current transaction.
   procedure Commit (Database : in out Database_Connection) is abstract;

   --  Rollback the current transaction.
   procedure Rollback (Database : in out Database_Connection) is abstract;

   --  Load the database schema definition for the current database.
   procedure Load_Schema (Database : in Database_Connection;
                          Schema   : out ADO.Schemas.Schema_Definition) is abstract;

   --  Get the database driver which manages this connection.
   function Get_Driver (Database : in Database_Connection)
                        return Driver_Access is abstract;

   --  Closes the database connection
   procedure Close (Database : in out Database_Connection) is abstract;

   --  ------------------------------
   --  The database configuration properties
   --  ------------------------------
   type Configuration is new Ada.Finalization.Controlled with private;
   type Configuration_Access is access all Configuration'Class;

   --  Set the connection URL to connect to the database.
   --  The driver connection is a string of the form:
   --
   --   driver://[host][:port]/[database][?property1][=value1]...
   --
   --  If the string is invalid or if the driver cannot be found,
   --  the Connection_Error exception is raised.
   procedure Set_Connection (Controller : in out Configuration;
                             URI        : in String);

   --  Set a property on the datasource for the driver.
   --  The driver can retrieve the property to configure and open
   --  the database connection.
   procedure Set_Property (Controller : in out Configuration;
                           Name       : in String;
                           Value      : in String);

   --  Get a property from the data source configuration.
   --  If the property does not exist, an empty string is returned.
   function Get_Property (Controller : in Configuration;
                          Name       : in String) return String;

   --  Set the server hostname.
   procedure Set_Server (Controller : in out Configuration;
                         Server     : in String);

   --  Get the server hostname.
   function Get_Server (Controller : in Configuration) return String;

   --  Set the server port.
   procedure Set_Port (Controller : in out Configuration;
                       Port       : in Natural);

   --  Get the server port.
   function Get_Port (Controller : in Configuration) return Natural;

   --  Get the database name.
   function Get_Database (Controller : in Configuration) return String;

   --  Create a new connection using the configuration parameters.
   procedure Create_Connection (Config : in Configuration'Class;
                                Result : out Database_Connection_Access);

   --  ------------------------------
   --  Database Driver
   --  ------------------------------

   --  Create a new connection using the configuration parameters.
   procedure Create_Connection (D      : in out Driver;
                                Config : in Configuration'Class;
                                Result : out Database_Connection_Access) is abstract;

   --  Get the driver unique index.
   function Get_Driver_Index (D : in Driver) return Driver_Index;

   --  Get the driver name.
   function Get_Driver_Name (D : in Driver) return String;

   --  Register a database driver.
   procedure Register (Driver : in Driver_Access);

   --  Get a database driver given its name.
   function Get_Driver (Name : in String) return Driver_Access;

private

   type Driver is abstract new Ada.Finalization.Limited_Controlled with record
      Name  : Util.Strings.Name_Access;
      Index : Driver_Index;
   end record;

   type Configuration is new Ada.Finalization.Controlled with record
      URI        : Unbounded_String := Null_Unbounded_String;
      Server     : Unbounded_String := Null_Unbounded_String;
      Port       : Natural := 0;
      Database   : Unbounded_String := Null_Unbounded_String;
      Properties : Util.Properties.Manager;
      Driver     : Driver_Access;
   end record;

end ADO.Drivers.Connections;

Declare the Set_Port procedure and change the port type to a natural