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

with Wiki.Helpers;
with Wiki.Parsers.Html.Entities;
package body Wiki.Parsers.Html is

   --  Parse an HTML attribute
   procedure Parse_Attribute_Name (P    : in out Parser;
                                   Name : in out Wiki.Strings.BString);

   --  Parse a HTML/XML comment to strip it.
   procedure Parse_Comment (P : in out Parser);

   --  Parse a simple DOCTYPE declaration and ignore it.
   procedure Parse_Doctype (P : in out Parser);

   procedure Collect_Attributes (P     : in out Parser);
   function Is_Letter (C : in Wiki.Strings.WChar) return Boolean;
   procedure Collect_Attribute_Value (P     : in out Parser;
                                      Value : in out Wiki.Strings.BString);

   function Is_Letter (C : in Wiki.Strings.WChar) return Boolean is
   begin
      return C > ' ' and C /= ':' and C /= '>' and C /= ''' and C /= '"'
        and C /= '/' and C /= '=' and C /= '<';
   end Is_Letter;

   --  ------------------------------
   --  Parse an HTML attribute
   --  ------------------------------
   procedure Parse_Attribute_Name (P    : in out Parser;
                                   Name : in out Wiki.Strings.BString) is
      C : Wiki.Strings.WChar;
   begin
      Skip_Spaces (P);
      while not P.Is_Eof loop
         Peek (P, C);
         if not Is_Letter (C) then
            Put_Back (P, C);
            return;
         end if;
         Wiki.Strings.Wide_Wide_Builders.Append (Name, C);
      end loop;
   end Parse_Attribute_Name;

   procedure Collect_Attribute_Value (P     : in out Parser;
                                      Value : in out Wiki.Strings.BString) is
      C     : Wiki.Strings.WChar;
      Token : Wiki.Strings.WChar;
   begin
--      Value := Wiki.Strings.To_UString ("");
      Peek (P, Token);
      if Wiki.Helpers.Is_Space (Token) then
         return;
      elsif Token = '>' then
         Put_Back (P, Token);
         return;
      elsif Token /= ''' and Token /= '"' then
         Wiki.Strings.Wide_Wide_Builders.Append (Value, Token);
         while not P.Is_Eof loop
            Peek (P, C);
            if C = ''' or C = '"' or C = ' ' or C = '=' or C = '>' or C = '<' or C = '`' then
               Put_Back (P, C);
               return;
            end if;
            Wiki.Strings.Wide_Wide_Builders.Append (Value, C);
         end loop;
      else
         while not P.Is_Eof loop
            Peek (P, C);
            if C = Token then
               return;
            end if;
            Wiki.Strings.Wide_Wide_Builders.Append (Value, C);
         end loop;
      end if;
   end Collect_Attribute_Value;

   --  ------------------------------
   --  Parse a list of HTML attributes up to the first '>'.
   --  attr-name
   --  attr-name=
   --  attr-name=value
   --  attr-name='value'
   --  attr-name="value"
   --  <name name='value' ...>
   --  ------------------------------
   procedure Collect_Attributes (P     : in out Parser) is
      procedure Append_Attribute (Name : in Wiki.Strings.WString);

      C     : Wiki.Strings.WChar;
      Name  : Wiki.Strings.BString (64);
      Value : Wiki.Strings.BString (256);

      procedure Append_Attribute (Name : in Wiki.Strings.WString) is

         procedure Attribute_Value (Value : in Wiki.Strings.WString);

         procedure Attribute_Value (Value : in Wiki.Strings.WString) is
         begin
            Attributes.Append (P.Attributes, Name, Value);
         end Attribute_Value;

         procedure Attribute_Value is
           new Wiki.Strings.Wide_Wide_Builders.Get (Attribute_Value);
         pragma Inline (Attribute_Value);

      begin
         Attribute_Value (Value);
      end Append_Attribute;
      pragma Inline (Append_Attribute);

      procedure Append_Attribute is
        new Wiki.Strings.Wide_Wide_Builders.Get (Append_Attribute);

   begin
      Wiki.Attributes.Clear (P.Attributes);
      while not P.Is_Eof loop
         Parse_Attribute_Name (P, Name);
         Skip_Spaces (P);
         Peek (P, C);
         if C = '>' or C = '<' or C = '/' then
            Put_Back (P, C);
            exit;
         end if;
         if C = '=' then
            Collect_Attribute_Value (P, Value);
            Append_Attribute (Name);
            Wiki.Strings.Wide_Wide_Builders.Clear (Name);
            Wiki.Strings.Wide_Wide_Builders.Clear (Value);
         elsif Wiki.Strings.Wide_Wide_Builders.Length (Name) > 0 then
            Put_Back (P, C);
            Append_Attribute (Name);
            Wiki.Strings.Wide_Wide_Builders.Clear (Name);
         end if;
      end loop;

      --  Add any pending attribute.
      if Wiki.Strings.Wide_Wide_Builders.Length (Name) > 0 then
         Append_Attribute (Name);
      end if;
   end Collect_Attributes;

   --  ------------------------------
   --  Parse a HTML/XML comment to strip it.
   --  ------------------------------
   procedure Parse_Comment (P : in out Parser) is
      C     : Wiki.Strings.WChar;
   begin
      Peek (P, C);
      while not P.Is_Eof loop
         Peek (P, C);
         if C = '-' then
            declare
               Count : Natural := 1;
            begin
               Peek (P, C);
               while not P.Is_Eof and C = '-' loop
                  Peek (P, C);
                  Count := Count + 1;
               end loop;
               exit when C = '>' and Count >= 2;
            end;
         end if;
      end loop;
   end Parse_Comment;

   --  ------------------------------
   --  Parse a simple DOCTYPE declaration and ignore it.
   --  ------------------------------
   procedure Parse_Doctype (P : in out Parser) is
      C : Wiki.Strings.WChar;
   begin
      while not P.Is_Eof loop
         Peek (P, C);
         exit when C = '>';
      end loop;
   end Parse_Doctype;

   --  ------------------------------
   --  Parse a HTML element <XXX attributes>
   --  or parse an end of HTML element </XXX>
   --  ------------------------------
   procedure Parse_Element (P : in out Parser) is
      C    : Wiki.Strings.WChar;

      procedure Add_Element (Token : in Wiki.Strings.WString);

      procedure Add_Element (Token : in Wiki.Strings.WString) is
         Tag  : Wiki.Html_Tag;
      begin
         Tag := Wiki.Find_Tag (Token);
         if C = '/' then
            Skip_Spaces (P);
            Peek (P, C);
            if C /= '>' then
               Put_Back (P, C);
            end if;
            Flush_Text (P);
            if Tag = Wiki.UNKNOWN_TAG then
               if Token = "noinclude" then
                  P.Context.Is_Hidden := not P.Context.Is_Included;
               elsif Token = "includeonly" then
                  P.Context.Is_Hidden := P.Context.Is_Included;
               end if;
            else
               End_Element (P, Tag);
            end if;
         else
            Collect_Attributes (P);
            Peek (P, C);
            if C = '/' then
               Peek (P, C);
               if C = '>' then
                  Start_Element (P, Tag, P.Attributes);
                  End_Element (P, Tag);
                  return;
               end if;
            elsif C /= '>' then
               Put_Back (P, C);
            end if;
            if Tag = UNKNOWN_TAG then
               if Token = "noinclude" then
                  P.Context.Is_Hidden := P.Context.Is_Included;
               elsif Token = "includeonly" then
                  P.Context.Is_Hidden := not P.Context.Is_Included;
               end if;
            else
               Start_Element (P, Tag, P.Attributes);
            end if;
         end if;
      end Add_Element;
      pragma Inline (Add_Element);

      procedure Add_Element is
        new Wiki.Strings.Wide_Wide_Builders.Get (Add_Element);
      pragma Inline (Add_Element);

      Name : Wiki.Strings.BString (64);
   begin
      Peek (P, C);
      if C = '!' then
         Peek (P, C);
         if C = '-' then
            Parse_Comment (P);
         else
            Parse_Doctype (P);
         end if;
         return;
      end if;
      if C /= '/' then
         Put_Back (P, C);
      end if;
      Parse_Attribute_Name (P, Name);
      Add_Element (Name);
   end Parse_Element;

   --  ------------------------------
   --  Parse an HTML entity such as   and replace it with the corresponding code.
   --  ------------------------------
   procedure Parse_Entity (P     : in out Parser;
                           Token : in Wiki.Strings.WChar) is
      pragma Unreferenced (Token);

      Name : String (1 .. 10);
      Len  : Natural := 0;
      High : Natural := Wiki.Parsers.Html.Entities.Keywords'Last;
      Low  : Natural := Wiki.Parsers.Html.Entities.Keywords'First;
      Pos  : Natural;
      C    : Wiki.Strings.WChar;
   begin
      while Len < Name'Last loop
         Peek (P, C);
         exit when C = ';' or else P.Is_Eof;
         Len := Len + 1;
         Name (Len) := Wiki.Strings.To_Char (C);
      end loop;
      while Low <= High loop
         Pos := (Low + High) / 2;
         if Wiki.Parsers.Html.Entities.Keywords (Pos).all = Name (1 .. Len) then
            Parse_Text (P, Entities.Mapping (Pos));
            return;
         elsif Entities.Keywords (Pos).all < Name (1 .. Len) then
            Low := Pos + 1;
         else
            High := Pos - 1;
         end if;
      end loop;

      if Len > 0 and then Name (Name'First) = '#'
        and then Name (Name'First + 1) >= '0' and then Name (Name'First + 1) <= '9'
      then
         begin
            C := Wiki.Strings.WChar'Val (Natural'Value (Name (Name'First + 1 .. Len)));
            Parse_Text (P, C);
            return;

         exception
            when Constraint_Error =>
               null;
         end;
      end if;

      --  The HTML entity is not recognized: we must treat it as plain wiki text.
      Parse_Text (P, '&');
      for I in 1 .. Len loop
         Parse_Text (P, Wiki.Strings.To_WChar (Name (I)));
      end loop;
      if Len > 0 and then Len < Name'Last and then C = ';' then
         Parse_Text (P, ';');
      end if;
   end Parse_Entity;

end Wiki.Parsers.Html;

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

with Interfaces;
with Wiki.Helpers;
with Wiki.Parsers.Html.Entities;
package body Wiki.Parsers.Html is

   --  Parse an HTML attribute
   procedure Parse_Attribute_Name (P    : in out Parser;
                                   Name : in out Wiki.Strings.BString);

   --  Parse a HTML/XML comment to strip it.
   procedure Parse_Comment (P : in out Parser);

   --  Parse a simple DOCTYPE declaration and ignore it.
   procedure Parse_Doctype (P : in out Parser);

   procedure Collect_Attributes (P     : in out Parser);
   function Is_Letter (C : in Wiki.Strings.WChar) return Boolean;
   procedure Collect_Attribute_Value (P     : in out Parser;
                                      Value : in out Wiki.Strings.BString);

   function Is_Letter (C : in Wiki.Strings.WChar) return Boolean is
   begin
      return C > ' ' and C /= ':' and C /= '>' and C /= ''' and C /= '"'
        and C /= '/' and C /= '=' and C /= '<';
   end Is_Letter;

   --  ------------------------------
   --  Parse an HTML attribute
   --  ------------------------------
   procedure Parse_Attribute_Name (P    : in out Parser;
                                   Name : in out Wiki.Strings.BString) is
      C : Wiki.Strings.WChar;
   begin
      Skip_Spaces (P);
      while not P.Is_Eof loop
         Peek (P, C);
         if not Is_Letter (C) then
            Put_Back (P, C);
            return;
         end if;
         Wiki.Strings.Wide_Wide_Builders.Append (Name, C);
      end loop;
   end Parse_Attribute_Name;

   procedure Collect_Attribute_Value (P     : in out Parser;
                                      Value : in out Wiki.Strings.BString) is
      C     : Wiki.Strings.WChar;
      Token : Wiki.Strings.WChar;
   begin
--      Value := Wiki.Strings.To_UString ("");
      Peek (P, Token);
      if Wiki.Helpers.Is_Space (Token) then
         return;
      elsif Token = '>' then
         Put_Back (P, Token);
         return;
      elsif Token /= ''' and Token /= '"' then
         Wiki.Strings.Wide_Wide_Builders.Append (Value, Token);
         while not P.Is_Eof loop
            Peek (P, C);
            if C = ''' or C = '"' or C = ' ' or C = '=' or C = '>' or C = '<' or C = '`' then
               Put_Back (P, C);
               return;
            end if;
            Wiki.Strings.Wide_Wide_Builders.Append (Value, C);
         end loop;
      else
         while not P.Is_Eof loop
            Peek (P, C);
            if C = Token then
               return;
            end if;
            Wiki.Strings.Wide_Wide_Builders.Append (Value, C);
         end loop;
      end if;
   end Collect_Attribute_Value;

   --  ------------------------------
   --  Parse a list of HTML attributes up to the first '>'.
   --  attr-name
   --  attr-name=
   --  attr-name=value
   --  attr-name='value'
   --  attr-name="value"
   --  <name name='value' ...>
   --  ------------------------------
   procedure Collect_Attributes (P     : in out Parser) is
      procedure Append_Attribute (Name : in Wiki.Strings.WString);

      C     : Wiki.Strings.WChar;
      Name  : Wiki.Strings.BString (64);
      Value : Wiki.Strings.BString (256);

      procedure Append_Attribute (Name : in Wiki.Strings.WString) is

         procedure Attribute_Value (Value : in Wiki.Strings.WString);

         procedure Attribute_Value (Value : in Wiki.Strings.WString) is
         begin
            Attributes.Append (P.Attributes, Name, Value);
         end Attribute_Value;

         procedure Attribute_Value is
           new Wiki.Strings.Wide_Wide_Builders.Get (Attribute_Value);
         pragma Inline (Attribute_Value);

      begin
         Attribute_Value (Value);
      end Append_Attribute;
      pragma Inline (Append_Attribute);

      procedure Append_Attribute is
        new Wiki.Strings.Wide_Wide_Builders.Get (Append_Attribute);

   begin
      Wiki.Attributes.Clear (P.Attributes);
      while not P.Is_Eof loop
         Parse_Attribute_Name (P, Name);
         Skip_Spaces (P);
         Peek (P, C);
         if C = '>' or C = '<' or C = '/' then
            Put_Back (P, C);
            exit;
         end if;
         if C = '=' then
            Collect_Attribute_Value (P, Value);
            Append_Attribute (Name);
            Wiki.Strings.Wide_Wide_Builders.Clear (Name);
            Wiki.Strings.Wide_Wide_Builders.Clear (Value);
         elsif Wiki.Strings.Wide_Wide_Builders.Length (Name) > 0 then
            Put_Back (P, C);
            Append_Attribute (Name);
            Wiki.Strings.Wide_Wide_Builders.Clear (Name);
         end if;
      end loop;

      --  Add any pending attribute.
      if Wiki.Strings.Wide_Wide_Builders.Length (Name) > 0 then
         Append_Attribute (Name);
      end if;
   end Collect_Attributes;

   --  ------------------------------
   --  Parse a HTML/XML comment to strip it.
   --  ------------------------------
   procedure Parse_Comment (P : in out Parser) is
      C     : Wiki.Strings.WChar;
   begin
      Peek (P, C);
      while not P.Is_Eof loop
         Peek (P, C);
         if C = '-' then
            declare
               Count : Natural := 1;
            begin
               Peek (P, C);
               while not P.Is_Eof and C = '-' loop
                  Peek (P, C);
                  Count := Count + 1;
               end loop;
               exit when C = '>' and Count >= 2;
            end;
         end if;
      end loop;
   end Parse_Comment;

   --  ------------------------------
   --  Parse a simple DOCTYPE declaration and ignore it.
   --  ------------------------------
   procedure Parse_Doctype (P : in out Parser) is
      C : Wiki.Strings.WChar;
   begin
      while not P.Is_Eof loop
         Peek (P, C);
         exit when C = '>';
      end loop;
   end Parse_Doctype;

   --  ------------------------------
   --  Parse a HTML element <XXX attributes>
   --  or parse an end of HTML element </XXX>
   --  ------------------------------
   procedure Parse_Element (P : in out Parser) is
      C    : Wiki.Strings.WChar;

      procedure Add_Element (Token : in Wiki.Strings.WString);

      procedure Add_Element (Token : in Wiki.Strings.WString) is
         Tag  : Wiki.Html_Tag;
      begin
         Tag := Wiki.Find_Tag (Token);
         if C = '/' then
            Skip_Spaces (P);
            Peek (P, C);
            if C /= '>' then
               Put_Back (P, C);
            end if;
            Flush_Text (P);
            if Tag = Wiki.UNKNOWN_TAG then
               if Token = "noinclude" then
                  P.Context.Is_Hidden := not P.Context.Is_Included;
               elsif Token = "includeonly" then
                  P.Context.Is_Hidden := P.Context.Is_Included;
               end if;
            else
               End_Element (P, Tag);
            end if;
         else
            Collect_Attributes (P);
            Peek (P, C);
            if C = '/' then
               Peek (P, C);
               if C = '>' then
                  Start_Element (P, Tag, P.Attributes);
                  End_Element (P, Tag);
                  return;
               end if;
            elsif C /= '>' then
               Put_Back (P, C);
            end if;
            if Tag = UNKNOWN_TAG then
               if Token = "noinclude" then
                  P.Context.Is_Hidden := P.Context.Is_Included;
               elsif Token = "includeonly" then
                  P.Context.Is_Hidden := not P.Context.Is_Included;
               end if;
            else
               Start_Element (P, Tag, P.Attributes);
            end if;
         end if;
      end Add_Element;
      pragma Inline (Add_Element);

      procedure Add_Element is
        new Wiki.Strings.Wide_Wide_Builders.Get (Add_Element);
      pragma Inline (Add_Element);

      Name : Wiki.Strings.BString (64);
   begin
      Peek (P, C);
      if C = '!' then
         Peek (P, C);
         if C = '-' then
            Parse_Comment (P);
         else
            Parse_Doctype (P);
         end if;
         return;
      end if;
      if C /= '/' then
         Put_Back (P, C);
      end if;
      Parse_Attribute_Name (P, Name);
      Add_Element (Name);
   end Parse_Element;

   use Interfaces;

   function From_Hex (C : in Character) return Interfaces.Unsigned_8 is
      (if C >= '0' and C <= '9' then Character'Pos (C) - Character'Pos ('0')
      elsif C >= 'A' and C <= 'F' then Character'Pos (C) - Character'Pos ('A') + 10
      elsif C >= 'a' and C <= 'f' then Character'Pos (C) - Character'Pos ('a') + 10
      else raise Constraint_Error);

   function From_Hex (Value : in String) return Wiki.Strings.WChar is
      Result : Interfaces.Unsigned_32 := 0;
   begin
      for C of Value loop
         Result := Interfaces.Shift_Left (Result, 4);
         Result := Result + Interfaces.Unsigned_32 (From_Hex (C));
      end loop;
      return Wiki.Strings.WChar'Val (Result);
   end From_Hex;

   --  ------------------------------
   --  Parse an HTML entity such as   and replace it with the corresponding code.
   --  ------------------------------
   procedure Parse_Entity (P     : in out Parser;
                           Token : in Wiki.Strings.WChar) is
      pragma Unreferenced (Token);

      Name : String (1 .. 10);
      Len  : Natural := 0;
      High : Natural := Wiki.Parsers.Html.Entities.Keywords'Last;
      Low  : Natural := Wiki.Parsers.Html.Entities.Keywords'First;
      Pos  : Natural;
      C    : Wiki.Strings.WChar;
   begin
      while Len < Name'Last loop
         Peek (P, C);
         exit when C = ';' or else P.Is_Eof;
         Len := Len + 1;
         Name (Len) := Wiki.Strings.To_Char (C);
      end loop;
      while Low <= High loop
         Pos := (Low + High) / 2;
         if Wiki.Parsers.Html.Entities.Keywords (Pos).all = Name (1 .. Len) then
            Parse_Text (P, Entities.Mapping (Pos));
            return;
         elsif Entities.Keywords (Pos).all < Name (1 .. Len) then
            Low := Pos + 1;
         else
            High := Pos - 1;
         end if;
      end loop;

      if Len > 0 and then Name (Name'First) = '#' then
         if Name (Name'First + 1) >= '0' and then Name (Name'First + 1) <= '9' then
            begin
               C := Wiki.Strings.WChar'Val (Natural'Value (Name (Name'First + 1 .. Len)));
               Parse_Text (P, C);
               return;

            exception
               when Constraint_Error =>
                  null;
            end;
         elsif Name (Name'First + 1) = 'x' then
            begin
               C := From_Hex (Name (Name'First + 2 .. Len));
               Parse_Text (P, C);
               return;

            exception
               when Constraint_Error =>
                  null;
            end;

         end if;
      end if;

      --  The HTML entity is not recognized: we must treat it as plain wiki text.
      Parse_Text (P, '&');
      for I in 1 .. Len loop
         Parse_Text (P, Wiki.Strings.To_WChar (Name (I)));
      end loop;
      if Len > 0 and then Len < Name'Last and then C = ';' then
         Parse_Text (P, ';');
      end if;
   end Parse_Entity;

end Wiki.Parsers.Html;

Add support to parse HTML entities in the hexadecimal form: &#xHHHH;


-----------------------------------------------------------------------
--  Appenders -- Log appenders
--  Copyright (C) 2001, 2002, 2003, 2006, 2008, 2009, 2010, 2011, 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.Calendar.Formatting;
with Ada.Strings;
with Ada.Strings.Fixed;

with Util.Strings.Transforms;
with Util.Log.Loggers;
with Util.Properties.Basic;
package body Util.Log.Appenders is

   use Ada;

   --  ------------------------------
   --  Get the log level that triggers display of the log events
   --  ------------------------------
   function Get_Level (Self : in Appender) return Level_Type is
   begin
      return Self.Level;
   end Get_Level;

   --  ------------------------------
   --  Set the log level.
   --  ------------------------------
   procedure Set_Level (Self       : in out Appender;
                        Name       : in String;
                        Properties : in Util.Properties.Manager;
                        Level      : in Level_Type) is
      Prop_Name : constant String := Name & ".level";
   begin
      if Properties.Exists (Prop_Name) then
         Self.Level := Get_Level (Properties.Get (Prop_Name), Level);
      else
         Self.Level := Level;
      end if;
   end Set_Level;

   --  ------------------------------
   --  Set the log layout format.
   --  ------------------------------
   procedure Set_Layout (Self       : in out Appender;
                         Name       : in String;
                         Properties : in Util.Properties.Manager;
                         Layout     : in Layout_Type) is
      use Ada.Strings;
      use Util.Strings.Transforms;
      Prop_Name : constant String := Name & ".layout";
   begin
      if Properties.Exists (Prop_Name) then
         declare
            Value : constant String
              := To_Lower_Case (Fixed.Trim (Properties.Get (Prop_Name), Both));
         begin
            if Value = "message" then
               Self.Layout := MESSAGE;
            elsif Value = "level-message" then
               Self.Layout := LEVEL_MESSAGE;
            elsif Value = "date-level-message" or Value = "level-date-message" then
               Self.Layout := DATE_LEVEL_MESSAGE;
            else
               Self.Layout := FULL;
            end if;
         end;
      else
         Self.Layout := Layout;
      end if;
   end Set_Layout;

   --  ------------------------------
   --  Format the event into a string
   --  ------------------------------
   function Format (Self  : in Appender;
                    Event : in Log_Event) return String is
   begin
      case Self.Layout is
         when MESSAGE =>
            return To_String (Event.Message);

         when LEVEL_MESSAGE =>
            return Get_Level_Name (Event.Level) & ": " & To_String (Event.Message);

         when DATE_LEVEL_MESSAGE =>
            return "[" & Calendar.Formatting.Image (Event.Time) & "] "
              & Get_Level_Name (Event.Level) & ": "
              & To_String (Event.Message);

         when FULL =>
            return "[" & Calendar.Formatting.Image (Event.Time) & "] "
              & Get_Level_Name (Event.Level) & " - "
              & Loggers.Get_Logger_Name (Event.Logger.all) & " - "
              & To_String (Event.Message);

      end case;
   end Format;

   procedure Append (Self  : in out File_Appender;
                     Event : in Log_Event) is
   begin
      if Self.Level >= Event.Level then
         Text_IO.Put_Line (Self.Output, Format (Self, Event));
         if Self.Immediate_Flush then
            Self.Flush;
         end if;
      end if;
   end Append;

   --  ------------------------------
   --  Flush the log events.
   --  ------------------------------
   overriding
   procedure Flush (Self   : in out File_Appender) is
   begin
      Text_IO.Flush (Self.Output);
   end Flush;

   --  ------------------------------
   --  Flush and close the file.
   --  ------------------------------
   overriding
   procedure Finalize (Self : in out File_Appender) is
   begin
      Self.Flush;
      Text_IO.Close (File => Self.Output);
   end Finalize;

   --  ------------------------------
   --  Create a file appender and configure it according to the properties
   --  ------------------------------
   function Create_File_Appender (Name       : in String;
                                  Properties : in Util.Properties.Manager;
                                  Default    : in Level_Type)
                                  return Appender_Access is
      use Util.Properties.Basic;

      Path   : constant String := Properties.Get (Name & ".File");
      Append : constant Boolean := Boolean_Property.Get (Properties, Name & ".append", True);
      Result : constant File_Appender_Access := new File_Appender;
   begin
      Result.Set_Level (Name, Properties, Default);
      Result.Set_Layout (Name, Properties, FULL);
      Result.Set_File (Path, Append);
      Result.Immediate_Flush := Boolean_Property.Get (Properties, Name & ".immediateFlush", True);
      return Result.all'Access;
   end Create_File_Appender;

   --  ------------------------------
   --  Set the file where the appender will write the logs.
   --  When <tt>Append</tt> is true, the log message are appended to the existing file.
   --  When set to false, the file is cleared before writing new messages.
   --  ------------------------------
   procedure Set_File (Self : in out File_Appender;
                       Path : in String;
                       Append : in Boolean := True) is
      Mode   : Text_IO.File_Mode;
   begin
      if Append then
         Mode := Text_IO.Append_File;
      else
         Mode := Text_IO.Out_File;
      end if;
      Text_IO.Open (File => Self.Output,
                    Name => Path,
                    Mode => Mode);
   exception
      when Text_IO.Name_Error =>
         Text_IO.Create (File => Self.Output, Name => Path);
   end Set_File;

   procedure Append (Self  : in out Console_Appender;
                     Event : in Log_Event) is
   begin
      if Self.Level >= Event.Level then
         Text_IO.Put_Line (Format (Self, Event));
      end if;
   end Append;

   --  ------------------------------
   --  Flush the log events.
   --  ------------------------------
   overriding
   procedure Flush (Self : in out Console_Appender) is
      pragma Unreferenced (Self);
   begin
      Text_IO.Flush;
   end Flush;

   overriding
   procedure Append (Self  : in out List_Appender;
                     Event : in Log_Event) is
   begin
      for I in 1 .. Self.Count loop
         Self.Appenders (I).Append (Event);
      end loop;
   end Append;

   --  ------------------------------
   --  Create a console appender and configure it according to the properties
   --  ------------------------------
   function Create_Console_Appender (Name       : in String;
                                     Properties : in Util.Properties.Manager;
                                     Default    : in Level_Type)
                                     return Appender_Access is
      Result : constant Console_Appender_Access := new Console_Appender;
   begin
      Result.Set_Level (Name, Properties, Default);
      Result.Set_Layout (Name, Properties, FULL);
      return Result.all'Access;
   end Create_Console_Appender;

   --  ------------------------------
   --  Flush the log events.
   --  ------------------------------
   overriding
   procedure Flush (Self   : in out List_Appender) is
   begin
      for I in 1 .. Self.Count loop
         Self.Appenders (I).Flush;
      end loop;
   end Flush;

   --  ------------------------------
   --  Add the appender to the list.
   --  ------------------------------
   procedure Add_Appender (Self   : in out List_Appender;
                           Object : in Appender_Access) is
   begin
      if Self.Count < Self.Appenders'Last then
         Self.Count := Self.Count + 1;
         Self.Appenders (Self.Count) := Object;
      end if;
   end Add_Appender;

   --  ------------------------------
   --  Create a list appender and configure it according to the properties
   --  ------------------------------
   function Create_List_Appender return List_Appender_Access is
      Result : constant List_Appender_Access := new List_Appender;
   begin
      return Result;
   end Create_List_Appender;

end Util.Log.Appenders;

-----------------------------------------------------------------------
--  util-log-appenders -- Log appenders
--  Copyright (C) 2001, 2002, 2003, 2006, 2008, 2009, 2010, 2011, 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.Calendar.Formatting;
with Ada.Strings;
with Ada.Strings.Fixed;

with Util.Strings.Transforms;
with Util.Log.Loggers;
with Util.Properties.Basic;
package body Util.Log.Appenders is

   use Ada;

   --  ------------------------------
   --  Get the log level that triggers display of the log events
   --  ------------------------------
   function Get_Level (Self : in Appender) return Level_Type is
   begin
      return Self.Level;
   end Get_Level;

   --  ------------------------------
   --  Set the log level.
   --  ------------------------------
   procedure Set_Level (Self       : in out Appender;
                        Name       : in String;
                        Properties : in Util.Properties.Manager;
                        Level      : in Level_Type) is
      Prop_Name : constant String := Name & ".level";
   begin
      if Properties.Exists (Prop_Name) then
         Self.Level := Get_Level (Properties.Get (Prop_Name), Level);
      else
         Self.Level := Level;
      end if;
   end Set_Level;

   --  ------------------------------
   --  Set the log layout format.
   --  ------------------------------
   procedure Set_Layout (Self       : in out Appender;
                         Name       : in String;
                         Properties : in Util.Properties.Manager;
                         Layout     : in Layout_Type) is
      use Ada.Strings;
      use Util.Strings.Transforms;
      Prop_Name : constant String := Name & ".layout";
   begin
      if Properties.Exists (Prop_Name) then
         declare
            Value : constant String
              := To_Lower_Case (Fixed.Trim (Properties.Get (Prop_Name), Both));
         begin
            if Value = "message" then
               Self.Layout := MESSAGE;
            elsif Value = "level-message" then
               Self.Layout := LEVEL_MESSAGE;
            elsif Value = "date-level-message" or Value = "level-date-message" then
               Self.Layout := DATE_LEVEL_MESSAGE;
            else
               Self.Layout := FULL;
            end if;
         end;
      else
         Self.Layout := Layout;
      end if;
   end Set_Layout;

   --  ------------------------------
   --  Format the event into a string
   --  ------------------------------
   function Format (Self  : in Appender;
                    Event : in Log_Event) return String is
   begin
      case Self.Layout is
         when MESSAGE =>
            return To_String (Event.Message);

         when LEVEL_MESSAGE =>
            return Get_Level_Name (Event.Level) & ": " & To_String (Event.Message);

         when DATE_LEVEL_MESSAGE =>
            return "[" & Calendar.Formatting.Image (Event.Time) & "] "
              & Get_Level_Name (Event.Level) & ": "
              & To_String (Event.Message);

         when FULL =>
            return "[" & Calendar.Formatting.Image (Event.Time) & "] "
              & Get_Level_Name (Event.Level) & " - "
              & Loggers.Get_Logger_Name (Event.Logger.all) & " - "
              & To_String (Event.Message);

      end case;
   end Format;

   procedure Append (Self  : in out File_Appender;
                     Event : in Log_Event) is
   begin
      if Self.Level >= Event.Level then
         Text_IO.Put_Line (Self.Output, Format (Self, Event));
         if Self.Immediate_Flush then
            Self.Flush;
         end if;
      end if;
   end Append;

   --  ------------------------------
   --  Flush the log events.
   --  ------------------------------
   overriding
   procedure Flush (Self   : in out File_Appender) is
   begin
      Text_IO.Flush (Self.Output);
   end Flush;

   --  ------------------------------
   --  Flush and close the file.
   --  ------------------------------
   overriding
   procedure Finalize (Self : in out File_Appender) is
   begin
      Self.Flush;
      Text_IO.Close (File => Self.Output);
   end Finalize;

   --  ------------------------------
   --  Create a file appender and configure it according to the properties
   --  ------------------------------
   function Create_File_Appender (Name       : in String;
                                  Properties : in Util.Properties.Manager;
                                  Default    : in Level_Type)
                                  return Appender_Access is
      use Util.Properties.Basic;

      Path   : constant String := Properties.Get (Name & ".File");
      Append : constant Boolean := Boolean_Property.Get (Properties, Name & ".append", True);
      Result : constant File_Appender_Access := new File_Appender;
   begin
      Result.Set_Level (Name, Properties, Default);
      Result.Set_Layout (Name, Properties, FULL);
      Result.Set_File (Path, Append);
      Result.Immediate_Flush := Boolean_Property.Get (Properties, Name & ".immediateFlush", True);
      return Result.all'Access;
   end Create_File_Appender;

   --  ------------------------------
   --  Set the file where the appender will write the logs.
   --  When <tt>Append</tt> is true, the log message are appended to the existing file.
   --  When set to false, the file is cleared before writing new messages.
   --  ------------------------------
   procedure Set_File (Self : in out File_Appender;
                       Path : in String;
                       Append : in Boolean := True) is
      Mode   : Text_IO.File_Mode;
   begin
      if Append then
         Mode := Text_IO.Append_File;
      else
         Mode := Text_IO.Out_File;
      end if;
      Text_IO.Open (File => Self.Output,
                    Name => Path,
                    Mode => Mode);
   exception
      when Text_IO.Name_Error =>
         Text_IO.Create (File => Self.Output, Name => Path);
   end Set_File;

   procedure Append (Self  : in out Console_Appender;
                     Event : in Log_Event) is
   begin
      if Self.Level >= Event.Level then
         Text_IO.Put_Line (Format (Self, Event));
      end if;
   end Append;

   --  ------------------------------
   --  Flush the log events.
   --  ------------------------------
   overriding
   procedure Flush (Self : in out Console_Appender) is
      pragma Unreferenced (Self);
   begin
      Text_IO.Flush;
   end Flush;

   overriding
   procedure Append (Self  : in out List_Appender;
                     Event : in Log_Event) is
   begin
      for I in 1 .. Self.Count loop
         Self.Appenders (I).Append (Event);
      end loop;
   end Append;

   --  ------------------------------
   --  Create a console appender and configure it according to the properties
   --  ------------------------------
   function Create_Console_Appender (Name       : in String;
                                     Properties : in Util.Properties.Manager;
                                     Default    : in Level_Type)
                                     return Appender_Access is
      Result : constant Console_Appender_Access := new Console_Appender;
   begin
      Result.Set_Level (Name, Properties, Default);
      Result.Set_Layout (Name, Properties, FULL);
      return Result.all'Access;
   end Create_Console_Appender;

   --  ------------------------------
   --  Flush the log events.
   --  ------------------------------
   overriding
   procedure Flush (Self   : in out List_Appender) is
   begin
      for I in 1 .. Self.Count loop
         Self.Appenders (I).Flush;
      end loop;
   end Flush;

   --  ------------------------------
   --  Add the appender to the list.
   --  ------------------------------
   procedure Add_Appender (Self   : in out List_Appender;
                           Object : in Appender_Access) is
   begin
      if Self.Count < Self.Appenders'Last then
         Self.Count := Self.Count + 1;
         Self.Appenders (Self.Count) := Object;
      end if;
   end Add_Appender;

   --  ------------------------------
   --  Create a list appender and configure it according to the properties
   --  ------------------------------
   function Create_List_Appender return List_Appender_Access is
      Result : constant List_Appender_Access := new List_Appender;
   begin
      return Result;
   end Create_List_Appender;

end Util.Log.Appenders;

Fix header style

Fix header style


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

with Util.Log;
with Util.Log.Loggers;
with Ada.Unchecked_Deallocation;

with ADO.Sequences;
with ADO.Statements.Create;
package body ADO.Sessions is

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("ADO.Sessions");

   procedure Check_Session (Database : in Session'Class;
                            Message  : in String := "") is
   begin
      if Database.Impl = null then
         Log.Error ("Session is closed or not initialized");
         raise Session_Error;
      end if;
      if Message'Length > 0 then
         Log.Info (Message, Database.Impl.Database.Value.Ident);
      end if;
   end Check_Session;

   --  ---------
   --  Session
   --  ---------

   --  ------------------------------
   --  Get the session status.
   --  ------------------------------
   function Get_Status (Database : in Session) return Connection_Status is
   begin
      if Database.Impl = null or else Database.Impl.Database.Is_Null then
         return CLOSED;
      else
         return OPEN;
      end if;
   end Get_Status;

   --  ------------------------------
   --  Get the database driver which manages this connection.
   --  ------------------------------
   function Get_Driver (Database : in Session) return ADO.Connections.Driver_Access is
   begin
      if Database.Impl = null or else Database.Impl.Database.Is_Null then
         return null;
      else
         return Database.Impl.Database.Value.Get_Driver;
      end if;
   end Get_Driver;

   --  ------------------------------
   --  Close the session.
   --  ------------------------------
   procedure Close (Database : in out Session) is

      procedure Free is new
        Ada.Unchecked_Deallocation (Object => Session_Record,
                                    Name   => Session_Record_Access);

      Is_Zero : Boolean;
   begin
      Log.Info ("Closing session");
      if Database.Impl /= null then
         ADO.Objects.Release_Proxy (Database.Impl.Proxy);
         Database.Impl.Database.Value.Close;
         Util.Concurrent.Counters.Decrement (Database.Impl.Counter, Is_Zero);
         if Is_Zero then
            Free (Database.Impl);
         end if;
         Database.Impl := null;
      end if;
   end Close;

   --  ------------------------------
   --  Insert a new cache in the manager.  The cache is identified by the given name.
   --  ------------------------------
   procedure Add_Cache (Database : in out Session;
                        Name     : in String;
                        Cache    : in ADO.Caches.Cache_Type_Access) is
   begin
      Check_Session (Database);
      Database.Impl.Values.Add_Cache (Name, Cache);
   end Add_Cache;

   --  ------------------------------
   --  Attach the object to the session.
   --  ------------------------------
   procedure Attach (Database : in out Session;
                     Object   : in ADO.Objects.Object_Ref'Class) is
      pragma Unreferenced (Object);
   begin
      Check_Session (Database);
   end Attach;

   --  ------------------------------
   --  Check if the session contains the object identified by the given key.
   --  ------------------------------
   function Contains (Database : in Session;
                      Item     : in ADO.Objects.Object_Key) return Boolean is
   begin
      Check_Session (Database);
      return ADO.Objects.Cache.Contains (Database.Impl.Cache, Item);
   end Contains;

   --  ------------------------------
   --  Remove the object from the session cache.
   --  ------------------------------
   procedure Evict (Database : in out Session;
                    Item     : in ADO.Objects.Object_Key) is
   begin
      Check_Session (Database);
      ADO.Objects.Cache.Remove (Database.Impl.Cache, Item);
   end Evict;

   --  ------------------------------
   --  Create a query statement.  The statement is not prepared
   --  ------------------------------
   function Create_Statement (Database : in Session;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Query_Statement is
   begin
      Check_Session (Database);
      declare
         Query : constant Query_Statement_Access
           := Database.Impl.Database.Value.all.Create_Statement (Table);
      begin
         return ADO.Statements.Create.Create_Statement (Query, Database.Impl.Values.all'Access);
      end;
   end Create_Statement;

   --  ------------------------------
   --  Create a query statement.  The statement is not prepared
   --  ------------------------------
   function Create_Statement (Database : in Session;
                              Query    : in String)
                              return Query_Statement is
   begin
      Check_Session (Database);
      declare
         Stmt : constant Query_Statement_Access
           := Database.Impl.Database.Value.all.Create_Statement (Query);
      begin
         return ADO.Statements.Create.Create_Statement (Stmt, Database.Impl.Values.all'Access);
      end;
   end Create_Statement;

   --  ------------------------------
   --  Create a query statement.  The statement is not prepared
   --  ------------------------------
   function Create_Statement (Database : in Session;
                              Query    : in ADO.Queries.Context'Class)
                              return Query_Statement is
   begin
      Check_Session (Database);
      declare
         SQL  : constant String := Query.Get_SQL (Database.Impl.Queries.all);
         Stmt : Query_Statement := Database.Create_Statement (SQL);
      begin
         Stmt.Set_Parameters (Query);
         return Stmt;
      end;
   end Create_Statement;

   --  ------------------------------
   --  Create a query statement and initialize the SQL statement with the query definition.
   --  ------------------------------
   function Create_Statement (Database : in Session;
                              Query    : in ADO.Queries.Query_Definition_Access)
                              return Query_Statement is
   begin
      Check_Session (Database);
      declare
         SQL   : constant String := ADO.Queries.Get_SQL (Query, Database.Impl.Queries.all, False);
      begin
         return Database.Create_Statement (SQL);
      end;
   end Create_Statement;

   --  ------------------------------
   --  Create a query statement.  The statement is not prepared
   --  ------------------------------
   function Create_Statement (Database : in Session;
                              Query    : in ADO.SQL.Query'Class;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Query_Statement is
   begin
      Check_Session (Database);
      declare
         Stmt : Query_Statement := Database.Create_Statement (Table);
      begin
         if Query in ADO.Queries.Context'Class then
            declare
               SQL : constant String
                 := ADO.Queries.Context'Class (Query).Get_SQL (Database.Impl.Queries.all);
            begin
               ADO.SQL.Append (Stmt.Get_Query.SQL, SQL);
            end;
         end if;
         Stmt.Set_Parameters (Query);
         return Stmt;
      end;
   end Create_Statement;

   --  ------------------------------
   --  Load the database schema definition for the current database.
   --  ------------------------------
   procedure Load_Schema (Database : in Session;
                          Schema   : out ADO.Schemas.Schema_Definition) is
   begin
      Check_Session (Database, "Loading schema {0}");
      Database.Impl.Database.Value.Load_Schema (Schema);
   end Load_Schema;

   --  ---------
   --  Master Session
   --  ---------

   --  ------------------------------
   --  Start a transaction.
   --  ------------------------------
   procedure Begin_Transaction (Database : in out Master_Session) is
   begin
      Check_Session (Database, "Begin transaction {0}");
      Database.Impl.Database.Value.Begin_Transaction;
   end Begin_Transaction;

   --  ------------------------------
   --  Commit the current transaction.
   --  ------------------------------
   procedure Commit (Database : in out Master_Session) is
   begin
      Check_Session (Database, "Commit transaction {0}");
      Database.Impl.Database.Value.Commit;
   end Commit;

   --  ------------------------------
   --  Rollback the current transaction.
   --  ------------------------------
   procedure Rollback (Database : in out Master_Session) is
   begin
      Check_Session (Database, "Rollback transaction {0}");
      Database.Impl.Database.Value.Rollback;
   end Rollback;

   --  ------------------------------
   --  Allocate an identifier for the table.
   --  ------------------------------
   procedure Allocate (Database : in out Master_Session;
                       Id       : in out ADO.Objects.Object_Record'Class) is
   begin
      Check_Session (Database);
      ADO.Sequences.Allocate (Database.Sequences.all, Id);
   end Allocate;

   --  ------------------------------
   --  Flush the objects that were modified.
   --  ------------------------------
   procedure Flush (Database : in out Master_Session) is
   begin
      Check_Session (Database);
   end Flush;

   overriding
   procedure Adjust (Object : in out Session) is
   begin
      if Object.Impl /= null then
         Util.Concurrent.Counters.Increment (Object.Impl.Counter);
      end if;
   end Adjust;

   overriding
   procedure Finalize (Object : in out Session) is
      procedure Free is
         new Ada.Unchecked_Deallocation (Object => Session_Record,
                                         Name   => Session_Record_Access);
      Is_Zero : Boolean;
   begin
      if Object.Impl /= null then
         Util.Concurrent.Counters.Decrement (Object.Impl.Counter, Is_Zero);
         if Is_Zero then
            ADO.Objects.Release_Proxy (Object.Impl.Proxy, Detach => True);
            if not Object.Impl.Database.Is_Null then
               Object.Impl.Database.Value.Close;
            end if;
            Free (Object.Impl);
         end if;
         Object.Impl := null;
      end if;
   end Finalize;

   --  ------------------------------
   --  Create a delete statement
   --  ------------------------------
   function Create_Statement (Database : in Master_Session;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Delete_Statement is
   begin
      Check_Session (Database);
      declare
         Stmt : constant Delete_Statement_Access
           := Database.Impl.Database.Value.all.Create_Statement (Table);
      begin
         return ADO.Statements.Create.Create_Statement (Stmt.all'Access,
                                                        Database.Impl.Values.all'Access);
      end;
   end Create_Statement;

   --  ------------------------------
   --  Create an update statement
   --  ------------------------------
   function Create_Statement (Database : in Master_Session;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Update_Statement is
   begin
      Check_Session (Database);
      declare
         Stmt : constant Update_Statement_Access
           := Database.Impl.Database.Value.all.Create_Statement (Table);
      begin
         return ADO.Statements.Create.Create_Statement (Stmt.all'Access,
                                                        Database.Impl.Values.all'Access);
      end;
   end Create_Statement;

   --  ------------------------------
   --  Create an insert statement
   --  ------------------------------
   function Create_Statement (Database : in Master_Session;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Insert_Statement is
   begin
      Check_Session (Database);
      declare
         Stmt : constant Insert_Statement_Access
           := Database.Impl.Database.Value.all.Create_Statement (Table);
      begin
         return ADO.Statements.Create.Create_Statement (Stmt.all'Access,
                                                        Database.Impl.Values.all'Access);
      end;
   end Create_Statement;

   --  ------------------------------
   --  Get the audit manager.
   --  ------------------------------
   function Get_Audit_Manager (Database : in Master_Session)
                               return access Audits.Audit_Manager'Class is
   begin
      return Database.Audit;
   end Get_Audit_Manager;

   --  ------------------------------
   --  Internal operation to get access to the database connection.
   --  ------------------------------
   procedure Access_Connection (Database : in out Master_Session;
                                Process  : not null access
                                  procedure (Connection : in out Database_Connection'Class)) is
   begin
      Check_Session (Database);
      Process (Database.Impl.Database.Value.all);
   end Access_Connection;

   --  ------------------------------
   --  Internal method to get the session proxy associated with the given database session.
   --  The session proxy is associated with some ADO objects to be able to retrieve the database
   --  session for the implementation of lazy loading.  The session proxy is kept until the
   --  session exist and at least one ADO object is refering to it.
   --  ------------------------------
   function Get_Session_Proxy (Database : in Session) return ADO.Objects.Session_Proxy_Access is
      use type ADO.Objects.Session_Proxy_Access;
   begin
      Check_Session (Database);
      if Database.Impl.Proxy = null then
         Database.Impl.Proxy := ADO.Objects.Create_Session_Proxy (Database.Impl);
      end if;
      return Database.Impl.Proxy;
   end Get_Session_Proxy;

end ADO.Sessions;

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

with Util.Log;
with Util.Log.Loggers;
with Ada.Unchecked_Deallocation;

with ADO.Sequences;
with ADO.Statements.Create;
package body ADO.Sessions is

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("ADO.Sessions");

   procedure Check_Session (Database : in Session'Class;
                            Message  : in String := "") is
   begin
      if Database.Impl = null then
         Log.Error ("Session is closed or not initialized");
         raise Session_Error;
      end if;
      if Message'Length > 0 then
         Log.Info (Message, Database.Impl.Database.Value.Ident);
      end if;
   end Check_Session;

   --  ---------
   --  Session
   --  ---------

   --  ------------------------------
   --  Get the session status.
   --  ------------------------------
   function Get_Status (Database : in Session) return Connection_Status is
   begin
      if Database.Impl = null or else Database.Impl.Database.Is_Null then
         return CLOSED;
      else
         return OPEN;
      end if;
   end Get_Status;

   --  ------------------------------
   --  Get the database driver which manages this connection.
   --  ------------------------------
   function Get_Driver (Database : in Session) return ADO.Connections.Driver_Access is
   begin
      if Database.Impl = null or else Database.Impl.Database.Is_Null then
         return null;
      else
         return Database.Impl.Database.Value.Get_Driver;
      end if;
   end Get_Driver;

   --  ------------------------------
   --  Close the session.
   --  ------------------------------
   procedure Close (Database : in out Session) is

      procedure Free is new
        Ada.Unchecked_Deallocation (Object => Session_Record,
                                    Name   => Session_Record_Access);

      Is_Zero : Boolean;
   begin
      Log.Info ("Closing session");
      if Database.Impl /= null then
         ADO.Objects.Release_Proxy (Database.Impl.Proxy);
         Database.Impl.Database.Value.Close;
         Util.Concurrent.Counters.Decrement (Database.Impl.Counter, Is_Zero);
         if Is_Zero then
            Free (Database.Impl);
         end if;
         Database.Impl := null;
      end if;
   end Close;

   --  ------------------------------
   --  Insert a new cache in the manager.  The cache is identified by the given name.
   --  ------------------------------
   procedure Add_Cache (Database : in out Session;
                        Name     : in String;
                        Cache    : in ADO.Caches.Cache_Type_Access) is
   begin
      Check_Session (Database);
      Database.Impl.Values.Add_Cache (Name, Cache);
   end Add_Cache;

   --  ------------------------------
   --  Attach the object to the session.
   --  ------------------------------
   procedure Attach (Database : in out Session;
                     Object   : in ADO.Objects.Object_Ref'Class) is
      pragma Unreferenced (Object);
   begin
      Check_Session (Database);
   end Attach;

   --  ------------------------------
   --  Check if the session contains the object identified by the given key.
   --  ------------------------------
   function Contains (Database : in Session;
                      Item     : in ADO.Objects.Object_Key) return Boolean is
   begin
      Check_Session (Database);
      return ADO.Objects.Cache.Contains (Database.Impl.Cache, Item);
   end Contains;

   --  ------------------------------
   --  Remove the object from the session cache.
   --  ------------------------------
   procedure Evict (Database : in out Session;
                    Item     : in ADO.Objects.Object_Key) is
   begin
      Check_Session (Database);
      ADO.Objects.Cache.Remove (Database.Impl.Cache, Item);
   end Evict;

   --  ------------------------------
   --  Create a query statement.  The statement is not prepared
   --  ------------------------------
   function Create_Statement (Database : in Session;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Query_Statement is
   begin
      Check_Session (Database);
      declare
         Query : constant Query_Statement_Access
           := Database.Impl.Database.Value.Create_Statement (Table);
      begin
         return ADO.Statements.Create.Create_Statement (Query, Database.Impl.Values.all'Access);
      end;
   end Create_Statement;

   --  ------------------------------
   --  Create a query statement.  The statement is not prepared
   --  ------------------------------
   function Create_Statement (Database : in Session;
                              Query    : in String)
                              return Query_Statement is
   begin
      Check_Session (Database);
      declare
         Stmt : constant Query_Statement_Access
           := Database.Impl.Database.Value.Create_Statement (Query);
      begin
         return ADO.Statements.Create.Create_Statement (Stmt, Database.Impl.Values.all'Access);
      end;
   end Create_Statement;

   --  ------------------------------
   --  Create a query statement.  The statement is not prepared
   --  ------------------------------
   function Create_Statement (Database : in Session;
                              Query    : in ADO.Queries.Context'Class)
                              return Query_Statement is
   begin
      Check_Session (Database);
      declare
         SQL  : constant String := Query.Get_SQL (Database.Impl.Queries.all);
         Stmt : Query_Statement := Database.Create_Statement (SQL);
      begin
         Stmt.Set_Parameters (Query);
         return Stmt;
      end;
   end Create_Statement;

   --  ------------------------------
   --  Create a query statement and initialize the SQL statement with the query definition.
   --  ------------------------------
   function Create_Statement (Database : in Session;
                              Query    : in ADO.Queries.Query_Definition_Access)
                              return Query_Statement is
   begin
      Check_Session (Database);
      declare
         SQL   : constant String := ADO.Queries.Get_SQL (Query, Database.Impl.Queries.all, False);
      begin
         return Database.Create_Statement (SQL);
      end;
   end Create_Statement;

   --  ------------------------------
   --  Create a query statement.  The statement is not prepared
   --  ------------------------------
   function Create_Statement (Database : in Session;
                              Query    : in ADO.SQL.Query'Class;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Query_Statement is
   begin
      Check_Session (Database);
      declare
         Stmt : Query_Statement := Database.Create_Statement (Table);
      begin
         if Query in ADO.Queries.Context'Class then
            declare
               SQL : constant String
                 := ADO.Queries.Context'Class (Query).Get_SQL (Database.Impl.Queries.all);
            begin
               ADO.SQL.Append (Stmt.Get_Query.SQL, SQL);
            end;
         end if;
         Stmt.Set_Parameters (Query);
         return Stmt;
      end;
   end Create_Statement;

   --  ------------------------------
   --  Load the database schema definition for the current database.
   --  ------------------------------
   procedure Load_Schema (Database : in Session;
                          Schema   : out ADO.Schemas.Schema_Definition) is
   begin
      Check_Session (Database, "Loading schema {0}");
      Database.Impl.Database.Value.Load_Schema (Schema);
   end Load_Schema;

   --  ---------
   --  Master Session
   --  ---------

   --  ------------------------------
   --  Start a transaction.
   --  ------------------------------
   procedure Begin_Transaction (Database : in out Master_Session) is
   begin
      Check_Session (Database, "Begin transaction {0}");
      Database.Impl.Database.Value.Begin_Transaction;
   end Begin_Transaction;

   --  ------------------------------
   --  Commit the current transaction.
   --  ------------------------------
   procedure Commit (Database : in out Master_Session) is
   begin
      Check_Session (Database, "Commit transaction {0}");
      Database.Impl.Database.Value.Commit;
   end Commit;

   --  ------------------------------
   --  Rollback the current transaction.
   --  ------------------------------
   procedure Rollback (Database : in out Master_Session) is
   begin
      Check_Session (Database, "Rollback transaction {0}");
      Database.Impl.Database.Value.Rollback;
   end Rollback;

   --  ------------------------------
   --  Allocate an identifier for the table.
   --  ------------------------------
   procedure Allocate (Database : in out Master_Session;
                       Id       : in out ADO.Objects.Object_Record'Class) is
   begin
      Check_Session (Database);
      ADO.Sequences.Allocate (Database.Sequences.all, Id);
   end Allocate;

   --  ------------------------------
   --  Flush the objects that were modified.
   --  ------------------------------
   procedure Flush (Database : in out Master_Session) is
   begin
      Check_Session (Database);
   end Flush;

   overriding
   procedure Adjust (Object : in out Session) is
   begin
      if Object.Impl /= null then
         Util.Concurrent.Counters.Increment (Object.Impl.Counter);
      end if;
   end Adjust;

   overriding
   procedure Finalize (Object : in out Session) is
      procedure Free is
         new Ada.Unchecked_Deallocation (Object => Session_Record,
                                         Name   => Session_Record_Access);
      Is_Zero : Boolean;
   begin
      if Object.Impl /= null then
         Util.Concurrent.Counters.Decrement (Object.Impl.Counter, Is_Zero);
         if Is_Zero then
            ADO.Objects.Release_Proxy (Object.Impl.Proxy, Detach => True);
            if not Object.Impl.Database.Is_Null then
               Object.Impl.Database.Value.Close;
            end if;
            Free (Object.Impl);
         end if;
         Object.Impl := null;
      end if;
   end Finalize;

   --  ------------------------------
   --  Create a delete statement
   --  ------------------------------
   function Create_Statement (Database : in Master_Session;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Delete_Statement is
   begin
      Check_Session (Database);
      declare
         Stmt : constant Delete_Statement_Access
           := Database.Impl.Database.Value.Create_Statement (Table);
      begin
         return ADO.Statements.Create.Create_Statement (Stmt.all'Access,
                                                        Database.Impl.Values.all'Access);
      end;
   end Create_Statement;

   --  ------------------------------
   --  Create an update statement
   --  ------------------------------
   function Create_Statement (Database : in Master_Session;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Update_Statement is
   begin
      Check_Session (Database);
      declare
         Stmt : constant Update_Statement_Access
           := Database.Impl.Database.Value.Create_Statement (Table);
      begin
         return ADO.Statements.Create.Create_Statement (Stmt.all'Access,
                                                        Database.Impl.Values.all'Access);
      end;
   end Create_Statement;

   --  ------------------------------
   --  Create an insert statement
   --  ------------------------------
   function Create_Statement (Database : in Master_Session;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Insert_Statement is
   begin
      Check_Session (Database);
      declare
         Stmt : constant Insert_Statement_Access
           := Database.Impl.Database.Value.Create_Statement (Table);
      begin
         return ADO.Statements.Create.Create_Statement (Stmt.all'Access,
                                                        Database.Impl.Values.all'Access);
      end;
   end Create_Statement;

   --  ------------------------------
   --  Get the audit manager.
   --  ------------------------------
   function Get_Audit_Manager (Database : in Master_Session)
                               return access Audits.Audit_Manager'Class is
   begin
      return Database.Audit;
   end Get_Audit_Manager;

   --  ------------------------------
   --  Internal operation to get access to the database connection.
   --  ------------------------------
   procedure Access_Connection (Database : in out Master_Session;
                                Process  : not null access
                                  procedure (Connection : in out Database_Connection'Class)) is
   begin
      Check_Session (Database);
      Process (Database.Impl.Database.Value);
   end Access_Connection;

   --  ------------------------------
   --  Internal method to get the session proxy associated with the given database session.
   --  The session proxy is associated with some ADO objects to be able to retrieve the database
   --  session for the implementation of lazy loading.  The session proxy is kept until the
   --  session exist and at least one ADO object is refering to it.
   --  ------------------------------
   function Get_Session_Proxy (Database : in Session) return ADO.Objects.Session_Proxy_Access is
      use type ADO.Objects.Session_Proxy_Access;
   begin
      Check_Session (Database);
      if Database.Impl.Proxy = null then
         Database.Impl.Proxy := ADO.Objects.Create_Session_Proxy (Database.Impl);
      end if;
      return Database.Impl.Proxy;
   end Get_Session_Proxy;

end ADO.Sessions;

Update to use Implicit_Deference support in Util.Refs


-----------------------------------------------------------------------
--  gen-artifacts-distribs-copies -- Copy based distribution artifact
--  Copyright (C) 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.Directories;

with Util.Log.Loggers;

--  The <b>Gen.Artifacts.Distribs.Copies</b> package provides distribution rules
--  to copy a file or a directory to the distribution area.
package body Gen.Artifacts.Distribs.Copies is

   use Util.Log;

   Log : constant Loggers.Logger := Loggers.Create ("Gen.Artifacts.Distribs.Copies");

   --  ------------------------------
   --  Create a distribution rule to copy a set of files or directories.
   --  ------------------------------
   function Create_Rule (Node : in DOM.Core.Node) return Distrib_Rule_Access is
      pragma Unreferenced (Node);

      Result : constant Copy_Rule_Access := new Copy_Rule;
   begin
      return Result.all'Access;
   end Create_Rule;

   --  ------------------------------
   --  Get a name to qualify the installation rule (used for logs).
   --  ------------------------------
   overriding
   function Get_Install_Name (Rule : in Copy_Rule) return String is
      pragma Unreferenced (Rule);
   begin
      return "copy";
   end Get_Install_Name;

   overriding
   procedure Install (Rule    : in Copy_Rule;
                      Path    : in String;
                      Files   : in File_Vector;
                      Context : in out Generator'Class) is
      pragma Unreferenced (Rule, Context);

      Source : constant String := Get_First_Path (Files);
      Dir    : constant String := Ada.Directories.Containing_Directory (Path);
   begin
      Log.Info ("copy {0} to {1}", Source, Path);

      Ada.Directories.Create_Path (Dir);
      Ada.Directories.Copy_File (Source_Name => Source,
                                 Target_Name => Path,
                                 Form        => "preserve=all_attributes, mode=overwrite");
   end Install;

end Gen.Artifacts.Distribs.Copies;

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

with Util.Log.Loggers;

--  The <b>Gen.Artifacts.Distribs.Copies</b> package provides distribution rules
--  to copy a file or a directory to the distribution area.
package body Gen.Artifacts.Distribs.Copies is

   use Util.Log;

   Log : constant Loggers.Logger := Loggers.Create ("Gen.Artifacts.Distribs.Copies");

   --  ------------------------------
   --  Create a distribution rule to copy a set of files or directories.
   --  ------------------------------
   function Create_Rule (Node : in DOM.Core.Node;
                         Copy_First_File : in Boolean) return Distrib_Rule_Access is
      pragma Unreferenced (Node);

      Result : constant Copy_Rule_Access := new Copy_Rule;
   begin
      Result.Copy_First_File := Copy_First_File;
      return Result.all'Access;
   end Create_Rule;

   --  ------------------------------
   --  Get a name to qualify the installation rule (used for logs).
   --  ------------------------------
   overriding
   function Get_Install_Name (Rule : in Copy_Rule) return String is
      pragma Unreferenced (Rule);
   begin
      return "copy";
   end Get_Install_Name;

   overriding
   procedure Install (Rule    : in Copy_Rule;
                      Path    : in String;
                      Files   : in File_Vector;
                      Context : in out Generator'Class) is
      pragma Unreferenced (Context);
      use type Ada.Containers.Count_Type;

      Source : constant String := Get_Source_Path (Files, Rule.Copy_First_File);
      Dir    : constant String := Ada.Directories.Containing_Directory (Path);
   begin
      if Files.Length > 1 then
         Log.Info ("copy {0} to {1} (ignoring {2} files)", Source, Path,
                   Natural'Image (Natural (Files.Length) - 1));
      else
         Log.Info ("copy {0} to {1}", Source, Path);
      end if;

      Ada.Directories.Create_Path (Dir);
      Ada.Directories.Copy_File (Source_Name => Source,
                                 Target_Name => Path,
                                 Form        => "preserve=all_attributes, mode=overwrite");
   end Install;

end Gen.Artifacts.Distribs.Copies;

Add a copy-first command to copy the first file found only (the default is to copy the last one since this is the reverse search path)


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

with Util.Test_Caller;
with Util.Systems.Os;
package body Util.Systems.DLLs.Tests is

   use Util.Tests;
   use type System.Address;

   function Get_Test_Library return String;
   function Get_Test_Symbol return String;

   package Caller is new Util.Test_Caller (Test, "Systems.Dlls");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Util.Systems.Dlls.Load",
                       Test_Load'Access);
      Caller.Add_Test (Suite, "Test Util.Systems.Dlls.Get_Symbol",
                       Test_Get_Symbol'Access);
   end Add_Tests;

   function Get_Test_Library return String is
   begin
      if Util.Systems.Os.Directory_Separator = '/' then
         return "libcrypto.so";
      else
         return "libz.dll";
      end if;
   end Get_Test_Library;

   function Get_Test_Symbol return String is
   begin
      if Util.Systems.Os.Directory_Separator = '/' then
         return "inflate";
      else
         return "compress";
      end if;
   end Get_Test_Symbol;

   --  ------------------------------
   --  Test the loading a shared library.
   --  ------------------------------
   procedure Test_Load (T : in out Test) is
      Lib : Handle;
   begin
      Lib := Util.Systems.DLLs.Load (Get_Test_Library);
      T.Assert (Lib /= Null_Handle, "Load operation returned null");

      begin
         Lib := Util.Systems.DLLs.Load ("some-invalid-library");

         T.Fail ("Load must raise an exception");

      exception
         when Load_Error =>
            null;
      end;
   end Test_Load;

   --  ------------------------------
   --  Test getting a shared library symbol.
   --  ------------------------------
   procedure Test_Get_Symbol (T : in out Test) is
      Lib : Handle;
      Sym : System.Address;
   begin
      Lib := Util.Systems.DLLs.Load (Get_Test_Library);
      T.Assert (Lib /= Null_Handle, "Load operation returned null");

      Sym := Util.Systems.DLLs.Get_Symbol (Lib, Get_Test_Symbol);
      T.Assert (Sym /= System.Null_Address, "Get_Symbol returned null");

      begin
         Sym := Util.Systems.DLLs.Get_Symbol (Lib, "some-invalid-symbol");
         T.Fail ("The Get_Symbol operation must raise an exception");

      exception
         when Not_Found =>
            null;

      end;
   end Test_Get_Symbol;

end Util.Systems.DLLs.Tests;

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

with Util.Test_Caller;
with Util.Systems.Os;
package body Util.Systems.DLLs.Tests is

   use Util.Tests;
   use type System.Address;

   function Get_Test_Library return String;
   function Get_Test_Symbol return String;

   package Caller is new Util.Test_Caller (Test, "Systems.Dlls");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Util.Systems.Dlls.Load",
                       Test_Load'Access);
      Caller.Add_Test (Suite, "Test Util.Systems.Dlls.Get_Symbol",
                       Test_Get_Symbol'Access);
   end Add_Tests;

   function Get_Test_Library return String is
   begin
      if Util.Systems.Os.Directory_Separator = '/' then
         return "libcrypto.so";
      else
         return "libz.dll";
      end if;
   end Get_Test_Library;

   function Get_Test_Symbol return String is
   begin
      if Util.Systems.Os.Directory_Separator = '/' then
         return "EVP_sha";
      else
         return "compress";
      end if;
   end Get_Test_Symbol;

   --  ------------------------------
   --  Test the loading a shared library.
   --  ------------------------------
   procedure Test_Load (T : in out Test) is
      Lib : Handle;
   begin
      Lib := Util.Systems.DLLs.Load (Get_Test_Library);
      T.Assert (Lib /= Null_Handle, "Load operation returned null");

      begin
         Lib := Util.Systems.DLLs.Load ("some-invalid-library");

         T.Fail ("Load must raise an exception");

      exception
         when Load_Error =>
            null;
      end;
   end Test_Load;

   --  ------------------------------
   --  Test getting a shared library symbol.
   --  ------------------------------
   procedure Test_Get_Symbol (T : in out Test) is
      Lib : Handle;
      Sym : System.Address;
   begin
      Lib := Util.Systems.DLLs.Load (Get_Test_Library);
      T.Assert (Lib /= Null_Handle, "Load operation returned null");

      Sym := Util.Systems.DLLs.Get_Symbol (Lib, Get_Test_Symbol);
      T.Assert (Sym /= System.Null_Address, "Get_Symbol returned null");

      begin
         Sym := Util.Systems.DLLs.Get_Symbol (Lib, "some-invalid-symbol");
         T.Fail ("The Get_Symbol operation must raise an exception");

      exception
         when Not_Found =>
            null;

      end;
   end Test_Get_Symbol;

end Util.Systems.DLLs.Tests;

Change the symbol name to use a symbol that hopefully exists in almost all installation of libcrypto on Unix


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

   type Event is tagged private;

   --  Get the time identifying when the event was created.
   function Get_Time (Ev : Event) return Ada.Calendar.Time;

private

   type Event is tagged record
      Date : Ada.Calendar.Time := Ada.Calendar.Clock;
   end record;

end Util.Events;

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

   type Event is tagged private;

   --  Get the time identifying when the event was created.
   function Get_Time (Ev : Event) return Ada.Calendar.Time;

   type Event_Listener is limited interface;

private

   type Event is tagged record
      Date : Ada.Calendar.Time := Ada.Calendar.Clock;
   end record;

end Util.Events;

Declare the Event_Listener interface

Declare the Event_Listener interface


-----------------------------------------------------------------------
--  ado.schemas -- Database Schemas
--  Copyright (C) 2009, 2010, 2011, 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 ADO.Statements;
with ADO.Statements.Create;
with ADO.SQL;
with Ada.Strings.Fixed;
package body ADO.Schemas.Mysql is

   use ADO.Statements;

   procedure Load_Table_Schema (C : in ADO.Drivers.Connections.Database_Connection'Class;
                                Table : in Table_Definition);

   function String_To_Type (Value : in String) return Column_Type;
   function String_To_Length (Value : in String) return Natural;

   function String_To_Type (Value : in String) return Column_Type is
      Pos : Natural;
   begin
      if Value = "date" then
         return T_DATE;
      elsif Value = "datetime" then
         return T_DATE_TIME;
      elsif Value = "int(11)" then
         return T_INTEGER;
      elsif Value = "bigint(20)" then
         return T_LONG_INTEGER;
      elsif Value = "tinyint(4)" then
         return T_TINYINT;
      elsif Value = "smallint(6)" then
         return T_SMALLINT;
      elsif Value = "longblob" then
         return T_BLOB;
      end if;
      Pos := Ada.Strings.Fixed.Index (Value, "(");
      if Pos > 0 then
         declare
            Name : constant String := Value (Value'First .. Pos - 1);
         begin
            if Name = "varchar" then
               return T_VARCHAR;
            elsif Name = "decimal" then
               return T_FLOAT;
            elsif Name = "int" then
               return T_INTEGER;
            elsif Name = "bigint" then
               return T_LONG_INTEGER;
            else
               return T_UNKNOWN;
            end if;
         end;
      end if;
      return T_UNKNOWN;
   end String_To_Type;

   function String_To_Length (Value : in String) return Natural is
      First : Natural;
      Last  : Natural;
   begin
      First := Ada.Strings.Fixed.Index (Value, "(");
      if First < 0 then
         return 0;
      end if;
      Last := Ada.Strings.Fixed.Index (Value , ")");
      if Last < First then
         return 0;
      end if;
      return Natural'Value (Value (First + 1 .. Last - 1));

   exception
      when Constraint_Error =>
         return 0;
   end String_To_Length;

   --  ------------------------------
   --  Load the table definition
   --  ------------------------------
   procedure Load_Table_Schema (C : in ADO.Drivers.Connections.Database_Connection'Class;
                                Table : in Table_Definition) is
      Name : constant String := Get_Name (Table);
      Stmt : Query_Statement
        := Create.Create_Statement (C.Create_Statement ("show full columns from "));
      Last : Column_Definition := null;
      Col  : Column_Definition;
      Value : Unbounded_String;
      Query : constant ADO.SQL.Query_Access := Stmt.Get_Query;
   begin
      ADO.SQL.Append_Name (Target => Query.SQL, Name => Name);
      Stmt.Execute;
      while Stmt.Has_Elements loop
         Col           := new Column;
         Col.Name      := Stmt.Get_Unbounded_String (0);
         if not Stmt.Is_Null (2) then
            Col.Collation := Stmt.Get_Unbounded_String (2);
         end if;
         if not Stmt.Is_Null (5) then
            Col.Default   := Stmt.Get_Unbounded_String (5);
         end if;
         if Last /= null then
            Last.Next_Column := Col;
         else
            Table.First_Column := Col;
         end if;

         Value := Stmt.Get_Unbounded_String (1);
         Col.Col_Type := String_To_Type (To_String (Value));
         Col.Size := String_To_Length (To_String (Value));

         Value := Stmt.Get_Unbounded_String (3);
         Col.Is_Null := Value = "YES";

         Value := Stmt.Get_Unbounded_String (4);
         Col.Is_Primary := Value = "PRI";

         Last := Col;
         Stmt.Next;
      end loop;
   end Load_Table_Schema;

   --  ------------------------------
   --  Load the database schema
   --  ------------------------------
   procedure Load_Schema (C      : in ADO.Drivers.Connections.Database_Connection'Class;
                          Schema : out Schema_Definition) is
      Stmt  : Query_Statement
        := Create.Create_Statement (C.Create_Statement ("show tables"));
      Table : Table_Definition;
      Last  : Table_Definition := null;
   begin
      Schema.Schema := new ADO.Schemas.Schema;
      Stmt.Execute;

      while Stmt.Has_Elements loop
         Table      := new ADO.Schemas.Table;
         Table.Name := Stmt.Get_Unbounded_String (0);
         if Last /= null then
            Last.Next_Table := Table;
         else
            Schema.Schema.First_Table := Table;
         end if;
         Load_Table_Schema (C, Table);
         Last := Table;
         Stmt.Next;
      end loop;
   end Load_Schema;

end ADO.Schemas.Mysql;

-----------------------------------------------------------------------
--  ado.schemas -- Database Schemas
--  Copyright (C) 2009, 2010, 2011, 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 ADO.Statements;
with ADO.Statements.Create;
with ADO.SQL;
with Ada.Strings.Fixed;
package body ADO.Schemas.Mysql is

   use ADO.Statements;

   procedure Load_Table_Schema (C : in ADO.Drivers.Connections.Database_Connection'Class;
                                Table : in Table_Definition);

   function String_To_Type (Value : in String) return Column_Type;
   function String_To_Length (Value : in String) return Natural;

   function String_To_Type (Value : in String) return Column_Type is
      Pos : Natural;
   begin
      if Value = "date" then
         return T_DATE;
      elsif Value = "datetime" then
         return T_DATE_TIME;
      elsif Value = "int(11)" then
         return T_INTEGER;
      elsif Value = "bigint(20)" then
         return T_LONG_INTEGER;
      elsif Value = "tinyint(4)" then
         return T_TINYINT;
      elsif Value = "smallint(6)" then
         return T_SMALLINT;
      elsif Value = "longblob" then
         return T_BLOB;
      end if;
      Pos := Ada.Strings.Fixed.Index (Value, "(");
      if Pos > 0 then
         declare
            Name : constant String := Value (Value'First .. Pos - 1);
         begin
            if Name = "varchar" then
               return T_VARCHAR;
            elsif Name = "decimal" then
               return T_FLOAT;
            elsif Name = "int" then
               return T_INTEGER;
            elsif Name = "bigint" then
               return T_LONG_INTEGER;
            else
               return T_UNKNOWN;
            end if;
         end;
      end if;
      return T_UNKNOWN;
   end String_To_Type;

   function String_To_Length (Value : in String) return Natural is
      First : Natural;
      Last  : Natural;
   begin
      First := Ada.Strings.Fixed.Index (Value, "(");
      if First = 0 then
         return 0;
      end if;
      Last := Ada.Strings.Fixed.Index (Value, ")");
      if Last < First then
         return 0;
      end if;
      return Natural'Value (Value (First + 1 .. Last - 1));

   exception
      when Constraint_Error =>
         return 0;
   end String_To_Length;

   --  ------------------------------
   --  Load the table definition
   --  ------------------------------
   procedure Load_Table_Schema (C : in ADO.Drivers.Connections.Database_Connection'Class;
                                Table : in Table_Definition) is
      Name : constant String := Get_Name (Table);
      Stmt : Query_Statement
        := Create.Create_Statement (C.Create_Statement ("show full columns from "));
      Last : Column_Definition := null;
      Col  : Column_Definition;
      Value : Unbounded_String;
      Query : constant ADO.SQL.Query_Access := Stmt.Get_Query;
   begin
      ADO.SQL.Append_Name (Target => Query.SQL, Name => Name);
      Stmt.Execute;
      while Stmt.Has_Elements loop
         Col           := new Column;
         Col.Name      := Stmt.Get_Unbounded_String (0);
         if not Stmt.Is_Null (2) then
            Col.Collation := Stmt.Get_Unbounded_String (2);
         end if;
         if not Stmt.Is_Null (5) then
            Col.Default   := Stmt.Get_Unbounded_String (5);
         end if;
         if Last /= null then
            Last.Next_Column := Col;
         else
            Table.First_Column := Col;
         end if;

         Value := Stmt.Get_Unbounded_String (1);
         Col.Col_Type := String_To_Type (To_String (Value));
         Col.Size := String_To_Length (To_String (Value));

         Value := Stmt.Get_Unbounded_String (3);
         Col.Is_Null := Value = "YES";

         Value := Stmt.Get_Unbounded_String (4);
         Col.Is_Primary := Value = "PRI";

         Last := Col;
         Stmt.Next;
      end loop;
   end Load_Table_Schema;

   --  ------------------------------
   --  Load the database schema
   --  ------------------------------
   procedure Load_Schema (C      : in ADO.Drivers.Connections.Database_Connection'Class;
                          Schema : out Schema_Definition) is
      Stmt  : Query_Statement
        := Create.Create_Statement (C.Create_Statement ("show tables"));
      Table : Table_Definition;
      Last  : Table_Definition := null;
   begin
      Schema.Schema := new ADO.Schemas.Schema;
      Stmt.Execute;

      while Stmt.Has_Elements loop
         Table      := new ADO.Schemas.Table;
         Table.Name := Stmt.Get_Unbounded_String (0);
         if Last /= null then
            Last.Next_Table := Table;
         else
            Schema.Schema.First_Table := Table;
         end if;
         Load_Table_Schema (C, Table);
         Last := Table;
         Stmt.Next;
      end loop;
   end Load_Schema;

end ADO.Schemas.Mysql;

Fix compilation warning

Fix compilation warning