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

with ASF.Utils;
with ASF.Applications.Messages;
with ASF.Components.Base;

--  The ASF.Components.Html.Messages package implements the h:message
--  and h:messages components.
package body ASF.Components.Html.Messages is

   use ASF.Components.Base;
   use ASF.Applications.Messages;

   MSG_ATTRIBUTE_NAMES    : Util.Strings.String_Set.Set;

   FATAL_ATTRIBUTE_NAMES  : Util.Strings.String_Set.Set;

   ERROR_ATTRIBUTE_NAMES  : Util.Strings.String_Set.Set;

   WARN_ATTRIBUTE_NAMES   : Util.Strings.String_Set.Set;

   INFO_ATTRIBUTE_NAMES   : Util.Strings.String_Set.Set;

   --  ------------------------------
   --  Check whether the UI component whose name is given in Name has some messages
   --  associated with it.
   --  ------------------------------
   function Has_Message (Name : in Util.Beans.Objects.Object) return Util.Beans.Objects.Object is
      Context  : constant ASF.Contexts.Faces.Faces_Context_Access := ASF.Contexts.Faces.Current;
   begin
      if Context = null then
         return Util.Beans.Objects.To_Object (False);
      end if;
      declare
         Id   : constant String := Util.Beans.Objects.To_String (Name);
         Msgs : constant ASF.Applications.Messages.Vectors.Cursor := Context.Get_Messages (Id);
      begin
         return Util.Beans.Objects.To_Object (Applications.Messages.Vectors.Has_Element (Msgs));
      end;
   end Has_Message;

   --  ------------------------------
   --  Write a single message enclosed by the tag represented by Tag.
   --  ------------------------------
   procedure Write_Message (UI           : in UIHtmlComponent'Class;
                            Message      : in ASF.Applications.Messages.Message;
                            Mode         : in Message_Mode;
                            Show_Detail  : in Boolean;
                            Show_Summary : in Boolean;
                            Context      : in out Faces_Context'Class) is
      Writer : constant Response_Writer_Access := Context.Get_Response_Writer;
   begin
      case Mode is
         when SPAN_NO_STYLE =>
            Writer.Start_Element ("span");

         when SPAN =>
            Writer.Start_Element ("span");
            UI.Render_Attributes (Context, MSG_ATTRIBUTE_NAMES, Writer);

         when LIST =>
            Writer.Start_Element ("li");

         when TABLE =>
            Writer.Start_Element ("tr");

      end case;

      case Get_Severity (Message) is
         when FATAL =>
            UI.Render_Attributes (Context, FATAL_ATTRIBUTE_NAMES, Writer);

         when ERROR =>
            UI.Render_Attributes (Context, ERROR_ATTRIBUTE_NAMES, Writer);

         when WARN =>
            UI.Render_Attributes (Context, WARN_ATTRIBUTE_NAMES, Writer);

         when INFO | NONE =>
            UI.Render_Attributes (Context, INFO_ATTRIBUTE_NAMES, Writer);

      end case;

      if Mode = TABLE then
         Writer.Start_Element ("td");
      end if;
      if Show_Summary then
         Writer.Write_Text (Get_Summary (Message));
      end if;
      if Show_Detail then
         Writer.Write_Text (Get_Detail (Message));
      end if;
      case Mode is
         when SPAN | SPAN_NO_STYLE =>
            Writer.End_Element ("span");

         when LIST =>
            Writer.End_Element ("li");

         when TABLE =>
            Writer.End_Element ("td");
            Writer.End_Element ("tr");

      end case;
   end Write_Message;

   --  ------------------------------
   --  Render a list of messages each of them being enclosed by the Tag element.
   --  ------------------------------
   procedure Write_Messages (UI       : in UIHtmlComponent'Class;
                             Mode     : in Message_Mode;
                             Context  : in out Faces_Context'Class;
                             Messages : in out ASF.Applications.Messages.Vectors.Cursor) is

      procedure Process_Message (Message : in ASF.Applications.Messages.Message);

      Show_Detail  : constant Boolean := UI.Get_Attribute ("showDetail", Context, True);
      Show_Summary : constant Boolean := UI.Get_Attribute ("showSummary", Context, False);

      procedure Process_Message (Message : in ASF.Applications.Messages.Message) is
      begin
         Write_Message (UI, Message, Mode, Show_Detail, Show_Summary, Context);
      end Process_Message;

   begin
      while ASF.Applications.Messages.Vectors.Has_Element (Messages) loop
         Vectors.Query_Element (Messages, Process_Message'Access);
         Vectors.Next (Messages);
      end loop;
   end Write_Messages;

   --  ------------------------------
   --  Encode the begining of the h:message component.
   --  ------------------------------
   procedure Encode_Begin (UI      : in UIMessage;
                           Context : in out Faces_Context'Class) is
   begin
      if not UI.Is_Rendered (Context) then
         return;
      end if;
      declare
         Name     : constant Util.Beans.Objects.Object := UI.Get_Attribute (Context, "for");
         Messages : ASF.Applications.Messages.Vectors.Cursor;
      begin
         --  No specification of 'for' attribute, render the global messages.
         if Util.Beans.Objects.Is_Null (Name) then
            Messages := Context.Get_Messages ("");
         else
            declare
               Id     : constant String := Util.Beans.Objects.To_String (Name);
               Target : constant UIComponent_Access := UI.Find (Id => Id);
            begin
               --  If the component does not exist, report an error in the logs.
               if Target = null then
                  UI.Log_Error ("Cannot find component {0}", Id);
               else
                  Messages := Context.Get_Messages (Id);
               end if;
            end;
         end if;

         --  If we have some message, render the first one (as specified by <h:message>).
         if ASF.Applications.Messages.Vectors.Has_Element (Messages) then
            declare
               Show_Detail  : constant Boolean := UI.Get_Attribute ("showDetail", Context, True);
               Show_Summary : constant Boolean := UI.Get_Attribute ("showSummary", Context, False);
            begin
               Write_Message (UI, ASF.Applications.Messages.Vectors.Element (Messages),
                              SPAN, Show_Detail, Show_Summary, Context);
            end;
         end if;
      end;
   end Encode_Begin;

   --  Encode the end of the h:message component.
   procedure Encode_End (UI      : in UIMessage;
                         Context : in out Faces_Context'Class) is
   begin
      null;
   end Encode_End;

   --  ------------------------------
   --  Encode the begining of the h:message component.
   --  ------------------------------
   procedure Encode_Begin (UI      : in UIMessages;
                           Context : in out Faces_Context'Class) is
   begin
      if UI.Is_Rendered (Context) then
         declare
            Name     : constant Util.Beans.Objects.Object := UI.Get_Attribute (Context, "for");
            Messages : ASF.Applications.Messages.Vectors.Cursor;
         begin
            --  No specification of 'for' attribute, render the global messages.
            if Util.Beans.Objects.Is_Null (Name) then
               if UI.Get_Attribute ("globalOnly", Context) then
                  Messages := Context.Get_Messages ("");
               end if;
            else
               declare
                  Id     : constant String := Util.Beans.Objects.To_String (Name);
                  Target : constant UIComponent_Access := UI.Find (Id => Id);
               begin
                  --  If the component does not exist, report an error in the logs.
                  if Target = null then
                     UI.Log_Error ("Cannot find component {0}", Id);
                  else
                     Messages := Context.Get_Messages (Id);
                  end if;
               end;
            end if;

            --  If we have some message, render them.
            if ASF.Applications.Messages.Vectors.Has_Element (Messages) then
               declare
                  Writer : constant Response_Writer_Access := Context.Get_Response_Writer;
                  Layout : constant String
                    := Util.Beans.Objects.To_String (UI.Get_Attribute (Context, "layout"));
               begin
                  if Layout = "table" then
                     Writer.Start_Element ("table");
                     UI.Render_Attributes (Context, MSG_ATTRIBUTE_NAMES, Writer);
                     Write_Messages (UI, TABLE, Context, Messages);
                     Writer.End_Element ("table");
                  else
                     Writer.Start_Element ("ul");
                     UI.Render_Attributes (Context, MSG_ATTRIBUTE_NAMES, Writer);
                     Write_Messages (UI, LIST, Context, Messages);
                     Writer.End_Element ("ul");
                  end if;
               end;
            end if;
         end;
      end if;
   end Encode_Begin;

   --  Encode the end of the h:message component.
   procedure Encode_End (UI      : in UIMessages;
                         Context : in out Faces_Context'Class) is
   begin
      null;
   end Encode_End;

   FATAL_CLASS_ATTR       : aliased constant String := "fatalClass";
   FATAL_STYLE_CLASS_ATTR : aliased constant String := "fatalStyle";

   ERROR_CLASS_ATTR       : aliased constant String := "errorClass";
   ERROR_STYLE_CLASS_ATTR : aliased constant String := "errorStyle";

   WARN_CLASS_ATTR        : aliased constant String := "warnClass";
   WARN_STYLE_CLASS_ATTR  : aliased constant String := "warnStyle";

   INFO_CLASS_ATTR        : aliased constant String := "infoClass";
   INFO_STYLE_CLASS_ATTR  : aliased constant String := "infoStyle";

begin
   ASF.Utils.Set_Text_Attributes (MSG_ATTRIBUTE_NAMES);
--     ASF.Utils.Set_Text_Attributes (WARN_ATTRIBUTE_NAMES);
--     ASF.Utils.Set_Text_Attributes (INFO_ATTRIBUTE_NAMES);
--
--     ASF.Utils.Set_Text_Attributes (FATAL_ATTRIBUTE_NAMES);
   FATAL_ATTRIBUTE_NAMES.Insert (FATAL_CLASS_ATTR'Access);
   FATAL_ATTRIBUTE_NAMES.Insert (FATAL_STYLE_CLASS_ATTR'Access);

   ERROR_ATTRIBUTE_NAMES.Insert (ERROR_CLASS_ATTR'Access);
   ERROR_ATTRIBUTE_NAMES.Insert (ERROR_STYLE_CLASS_ATTR'Access);

   WARN_ATTRIBUTE_NAMES.Insert (WARN_CLASS_ATTR'Access);
   WARN_ATTRIBUTE_NAMES.Insert (WARN_STYLE_CLASS_ATTR'Access);

   INFO_ATTRIBUTE_NAMES.Insert (INFO_CLASS_ATTR'Access);
   INFO_ATTRIBUTE_NAMES.Insert (INFO_STYLE_CLASS_ATTR'Access);
end ASF.Components.Html.Messages;

-----------------------------------------------------------------------
--  html.messages -- Faces messages
--  Copyright (C) 2011, 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 ASF.Utils;
with ASF.Applications.Messages;
with ASF.Components.Base;

--  The ASF.Components.Html.Messages package implements the h:message
--  and h:messages components.
package body ASF.Components.Html.Messages is

   use ASF.Components.Base;
   use ASF.Applications.Messages;

   MSG_ATTRIBUTE_NAMES    : Util.Strings.String_Set.Set;

   FATAL_ATTRIBUTE_NAMES  : Util.Strings.String_Set.Set;

   ERROR_ATTRIBUTE_NAMES  : Util.Strings.String_Set.Set;

   WARN_ATTRIBUTE_NAMES   : Util.Strings.String_Set.Set;

   INFO_ATTRIBUTE_NAMES   : Util.Strings.String_Set.Set;

   --  ------------------------------
   --  Check whether the UI component whose name is given in Name has some messages
   --  associated with it.
   --  ------------------------------
   function Has_Message (Name : in Util.Beans.Objects.Object) return Util.Beans.Objects.Object is
      Context  : constant ASF.Contexts.Faces.Faces_Context_Access := ASF.Contexts.Faces.Current;
   begin
      if Context = null then
         return Util.Beans.Objects.To_Object (False);
      end if;
      declare
         Id   : constant String := Util.Beans.Objects.To_String (Name);
         Msgs : constant ASF.Applications.Messages.Vectors.Cursor := Context.Get_Messages (Id);
      begin
         return Util.Beans.Objects.To_Object (Applications.Messages.Vectors.Has_Element (Msgs));
      end;
   end Has_Message;

   --  ------------------------------
   --  Write a single message enclosed by the tag represented by Tag.
   --  ------------------------------
   procedure Write_Message (UI           : in UIHtmlComponent'Class;
                            Message      : in ASF.Applications.Messages.Message;
                            Mode         : in Message_Mode;
                            Show_Detail  : in Boolean;
                            Show_Summary : in Boolean;
                            Context      : in out Faces_Context'Class) is
      Writer : constant Response_Writer_Access := Context.Get_Response_Writer;
   begin
      case Mode is
         when SPAN_NO_STYLE =>
            Writer.Start_Element ("span");

         when SPAN =>
            Writer.Start_Element ("span");
            UI.Render_Attributes (Context, MSG_ATTRIBUTE_NAMES, Writer);

         when LIST =>
            Writer.Start_Element ("li");

         when TABLE =>
            Writer.Start_Element ("tr");

      end case;

      case Get_Severity (Message) is
         when FATAL =>
            UI.Render_Attributes (Context, FATAL_ATTRIBUTE_NAMES, Writer,
                                  Write_Id => Mode /= SPAN_NO_STYLE);

         when ERROR =>
            UI.Render_Attributes (Context, ERROR_ATTRIBUTE_NAMES, Writer,
                                  Write_Id => Mode /= SPAN_NO_STYLE);

         when WARN =>
            UI.Render_Attributes (Context, WARN_ATTRIBUTE_NAMES, Writer,
                                  Write_Id => Mode /= SPAN_NO_STYLE);

         when INFO | NONE =>
            UI.Render_Attributes (Context, INFO_ATTRIBUTE_NAMES, Writer,
                                  Write_Id => Mode /= SPAN_NO_STYLE);

      end case;

      if Mode = TABLE then
         Writer.Start_Element ("td");
      end if;
      if Show_Summary then
         Writer.Write_Text (Get_Summary (Message));
      end if;
      if Show_Detail then
         Writer.Write_Text (Get_Detail (Message));
      end if;
      case Mode is
         when SPAN | SPAN_NO_STYLE =>
            Writer.End_Element ("span");

         when LIST =>
            Writer.End_Element ("li");

         when TABLE =>
            Writer.End_Element ("td");
            Writer.End_Element ("tr");

      end case;
   end Write_Message;

   --  ------------------------------
   --  Render a list of messages each of them being enclosed by the Tag element.
   --  ------------------------------
   procedure Write_Messages (UI       : in UIHtmlComponent'Class;
                             Mode     : in Message_Mode;
                             Context  : in out Faces_Context'Class;
                             Messages : in out ASF.Applications.Messages.Vectors.Cursor) is

      procedure Process_Message (Message : in ASF.Applications.Messages.Message);

      Show_Detail  : constant Boolean := UI.Get_Attribute ("showDetail", Context, True);
      Show_Summary : constant Boolean := UI.Get_Attribute ("showSummary", Context, False);

      procedure Process_Message (Message : in ASF.Applications.Messages.Message) is
      begin
         Write_Message (UI, Message, Mode, Show_Detail, Show_Summary, Context);
      end Process_Message;

   begin
      while ASF.Applications.Messages.Vectors.Has_Element (Messages) loop
         Vectors.Query_Element (Messages, Process_Message'Access);
         Vectors.Next (Messages);
      end loop;
   end Write_Messages;

   --  ------------------------------
   --  Encode the begining of the h:message component.
   --  ------------------------------
   procedure Encode_Begin (UI      : in UIMessage;
                           Context : in out Faces_Context'Class) is
   begin
      if not UI.Is_Rendered (Context) then
         return;
      end if;
      declare
         Name     : constant Util.Beans.Objects.Object := UI.Get_Attribute (Context, "for");
         Messages : ASF.Applications.Messages.Vectors.Cursor;
      begin
         --  No specification of 'for' attribute, render the global messages.
         if Util.Beans.Objects.Is_Null (Name) then
            Messages := Context.Get_Messages ("");
         else
            declare
               Id     : constant String := Util.Beans.Objects.To_String (Name);
               Target : constant UIComponent_Access := UI.Find (Id => Id);
            begin
               --  If the component does not exist, report an error in the logs.
               if Target = null then
                  UI.Log_Error ("Cannot find component {0}", Id);
               else
                  Messages := Context.Get_Messages (Id);
               end if;
            end;
         end if;

         --  If we have some message, render the first one (as specified by <h:message>).
         if ASF.Applications.Messages.Vectors.Has_Element (Messages) then
            declare
               Show_Detail  : constant Boolean := UI.Get_Attribute ("showDetail", Context, True);
               Show_Summary : constant Boolean := UI.Get_Attribute ("showSummary", Context, False);
            begin
               Write_Message (UI, ASF.Applications.Messages.Vectors.Element (Messages),
                              SPAN, Show_Detail, Show_Summary, Context);
            end;
         end if;
      end;
   end Encode_Begin;

   --  Encode the end of the h:message component.
   procedure Encode_End (UI      : in UIMessage;
                         Context : in out Faces_Context'Class) is
   begin
      null;
   end Encode_End;

   --  ------------------------------
   --  Encode the begining of the h:message component.
   --  ------------------------------
   procedure Encode_Begin (UI      : in UIMessages;
                           Context : in out Faces_Context'Class) is
   begin
      if UI.Is_Rendered (Context) then
         declare
            Name     : constant Util.Beans.Objects.Object := UI.Get_Attribute (Context, "for");
            Messages : ASF.Applications.Messages.Vectors.Cursor;
         begin
            --  No specification of 'for' attribute, render the global messages.
            if Util.Beans.Objects.Is_Null (Name) then
               if UI.Get_Attribute ("globalOnly", Context) then
                  Messages := Context.Get_Messages ("");
               end if;
            else
               declare
                  Id     : constant String := Util.Beans.Objects.To_String (Name);
                  Target : constant UIComponent_Access := UI.Find (Id => Id);
               begin
                  --  If the component does not exist, report an error in the logs.
                  if Target = null then
                     UI.Log_Error ("Cannot find component {0}", Id);
                  else
                     Messages := Context.Get_Messages (Id);
                  end if;
               end;
            end if;

            --  If we have some message, render them.
            if ASF.Applications.Messages.Vectors.Has_Element (Messages) then
               declare
                  Writer : constant Response_Writer_Access := Context.Get_Response_Writer;
                  Layout : constant String
                    := Util.Beans.Objects.To_String (UI.Get_Attribute (Context, "layout"));
               begin
                  if Layout = "table" then
                     Writer.Start_Element ("table");
                     UI.Render_Attributes (Context, MSG_ATTRIBUTE_NAMES, Writer);
                     Write_Messages (UI, TABLE, Context, Messages);
                     Writer.End_Element ("table");
                  else
                     Writer.Start_Element ("ul");
                     UI.Render_Attributes (Context, MSG_ATTRIBUTE_NAMES, Writer);
                     Write_Messages (UI, LIST, Context, Messages);
                     Writer.End_Element ("ul");
                  end if;
               end;
            end if;
         end;
      end if;
   end Encode_Begin;

   --  Encode the end of the h:message component.
   procedure Encode_End (UI      : in UIMessages;
                         Context : in out Faces_Context'Class) is
   begin
      null;
   end Encode_End;

   FATAL_CLASS_ATTR       : aliased constant String := "fatalClass";
   FATAL_STYLE_CLASS_ATTR : aliased constant String := "fatalStyle";

   ERROR_CLASS_ATTR       : aliased constant String := "errorClass";
   ERROR_STYLE_CLASS_ATTR : aliased constant String := "errorStyle";

   WARN_CLASS_ATTR        : aliased constant String := "warnClass";
   WARN_STYLE_CLASS_ATTR  : aliased constant String := "warnStyle";

   INFO_CLASS_ATTR        : aliased constant String := "infoClass";
   INFO_STYLE_CLASS_ATTR  : aliased constant String := "infoStyle";

begin
   ASF.Utils.Set_Text_Attributes (MSG_ATTRIBUTE_NAMES);
--     ASF.Utils.Set_Text_Attributes (WARN_ATTRIBUTE_NAMES);
--     ASF.Utils.Set_Text_Attributes (INFO_ATTRIBUTE_NAMES);
--
--     ASF.Utils.Set_Text_Attributes (FATAL_ATTRIBUTE_NAMES);
   FATAL_ATTRIBUTE_NAMES.Insert (FATAL_CLASS_ATTR'Access);
   FATAL_ATTRIBUTE_NAMES.Insert (FATAL_STYLE_CLASS_ATTR'Access);

   ERROR_ATTRIBUTE_NAMES.Insert (ERROR_CLASS_ATTR'Access);
   ERROR_ATTRIBUTE_NAMES.Insert (ERROR_STYLE_CLASS_ATTR'Access);

   WARN_ATTRIBUTE_NAMES.Insert (WARN_CLASS_ATTR'Access);
   WARN_ATTRIBUTE_NAMES.Insert (WARN_STYLE_CLASS_ATTR'Access);

   INFO_ATTRIBUTE_NAMES.Insert (INFO_CLASS_ATTR'Access);
   INFO_ATTRIBUTE_NAMES.Insert (INFO_STYLE_CLASS_ATTR'Access);
end ASF.Components.Html.Messages;

Disable the rendering of the component id for the SPAN_NO_STYLE mode


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

with Util.Tests;
with Util.Tests.Servers;
with Util.Streams.Texts;
with Util.Streams.Sockets;
package Util.Http.Clients.Tests is

   type Method_Type is (OPTIONS, GET, HEAD, POST, PUT, DELETE, TRACE, CONNECT, UNKNOWN);

   type Test_Server is new Util.Tests.Servers.Server with record
      Method       : Method_Type := UNKNOWN;
      Result       : Ada.Strings.Unbounded.Unbounded_String;
      Content_Type : Ada.Strings.Unbounded.Unbounded_String;
      Length       : Natural := 0;
   end record;
   type Test_Server_Access is access all Test_Server'Class;

   --  Process the line received by the server.
   overriding
   procedure Process_Line (Into   : in out Test_Server;
                           Line   : in Ada.Strings.Unbounded.Unbounded_String;
                           Stream : in out Util.Streams.Texts.Reader_Stream'Class;
                           Client : in out Util.Streams.Sockets.Socket_Stream'Class);

   type Test is new Util.Tests.Test with record
      Server : Test_Server_Access := null;
   end record;

   --  Test the http Get operation.
   procedure Test_Http_Get (T : in out Test);

   --  Test the http POST operation.
   procedure Test_Http_Post (T : in out Test);

   --  Test the http PUT operation.
   procedure Test_Http_Put (T : in out Test);

   --  Test the http DELETE operation.
   procedure Test_Http_Delete (T : in out Test);

   overriding
   procedure Set_Up (T : in out Test);

   overriding
   procedure Tear_Down (T : in out Test);

   --  Get the test server base URI.
   function Get_Uri (T : in Test) return String;

   --  The Http_Tests package must be instantiated with one of the HTTP implementation.
   --  The Register procedure configures the Http.Client to use the given HTTP
   --  implementation before running the test.
   generic
      with procedure Register;
      NAME : in String;
   package Http_Tests is
      procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite);

      type Http_Test is new Test with null record;

      overriding
      procedure Set_Up (T : in out Http_Test);

   end Http_Tests;

end Util.Http.Clients.Tests;

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

with Util.Tests;
with Util.Tests.Servers;
with Util.Streams.Texts;
with Util.Streams.Sockets;
package Util.Http.Clients.Tests is

   type Method_Type is (OPTIONS, GET, HEAD, POST, PUT, DELETE, TRACE, CONNECT, UNKNOWN);

   type Test_Server is new Util.Tests.Servers.Server with record
      Method       : Method_Type := UNKNOWN;
      Result       : Ada.Strings.Unbounded.Unbounded_String;
      Content_Type : Ada.Strings.Unbounded.Unbounded_String;
      Length       : Natural := 0;
      Test_Timeout : Boolean := False;
   end record;
   type Test_Server_Access is access all Test_Server'Class;

   --  Process the line received by the server.
   overriding
   procedure Process_Line (Into   : in out Test_Server;
                           Line   : in Ada.Strings.Unbounded.Unbounded_String;
                           Stream : in out Util.Streams.Texts.Reader_Stream'Class;
                           Client : in out Util.Streams.Sockets.Socket_Stream'Class);

   type Test is new Util.Tests.Test with record
      Server : Test_Server_Access := null;
   end record;

   --  Test the http Get operation.
   procedure Test_Http_Get (T : in out Test);

   --  Test the http POST operation.
   procedure Test_Http_Post (T : in out Test);

   --  Test the http PUT operation.
   procedure Test_Http_Put (T : in out Test);

   --  Test the http DELETE operation.
   procedure Test_Http_Delete (T : in out Test);

   --  Test the http timeout.
   procedure Test_Http_Timeout (T : in out Test);

   overriding
   procedure Set_Up (T : in out Test);

   overriding
   procedure Tear_Down (T : in out Test);

   --  Get the test server base URI.
   function Get_Uri (T : in Test) return String;

   --  The Http_Tests package must be instantiated with one of the HTTP implementation.
   --  The Register procedure configures the Http.Client to use the given HTTP
   --  implementation before running the test.
   generic
      with procedure Register;
      NAME : in String;
   package Http_Tests is
      procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite);

      type Http_Test is new Test with null record;

      overriding
      procedure Set_Up (T : in out Http_Test);

   end Http_Tests;

end Util.Http.Clients.Tests;

Declare Test_Http_Timeout procedure

Declare Test_Http_Timeout procedure


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

with ELF;
with MAT.Types;
with MAT.Frames;
with MAT.Events.Targets;

package MAT.Memory is

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

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

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

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

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

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

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

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

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

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

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

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

end MAT.Memory;

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

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

package MAT.Memory is

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

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

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

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

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

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

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

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

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

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

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

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

end MAT.Memory;

Fix compilation warning with GNAT 2018

Fix compilation warning with GNAT 2018


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

with MAT.Types;
with MAT.Events;
with MAT.Events.Targets;
with MAT.Readers;
with MAT.Frames;
package MAT.Events.Probes is

   -----------------
   --  Abstract probe definition
   -----------------
   type Probe_Type is abstract tagged limited private;
   type Probe_Type_Access is access all Probe_Type'Class;

   --  Extract the probe information from the message.
   procedure Extract (Probe  : in Probe_Type;
                      Params : in MAT.Events.Const_Attribute_Table_Access;
                      Msg    : in out MAT.Readers.Message_Type;
                      Event  : in out Target_Event_Type) is abstract;

   procedure Execute (Probe : in Probe_Type;
                      Event : in out Target_Event_Type) is abstract;

   --  Update the Size and Prev_Id information in the event identified by <tt>Id</tt>.
   --  Update the event represented by <tt>Prev_Id</tt> so that its Next_Id refers
   --  to the <tt>Id</tt> event.
   procedure Update_Event (Probe   : in Probe_Type;
                           Id      : in MAT.Events.Event_Id_Type;
                           Size    : in MAT.Types.Target_Size;
                           Prev_Id : in MAT.Events.Event_Id_Type);

   -----------------
   --  Probe Manager
   -----------------
   type Probe_Manager_Type is abstract new Ada.Finalization.Limited_Controlled with private;
   type Probe_Manager_Type_Access is access all Probe_Manager_Type'Class;

   --  Initialize the probe manager instance.
   overriding
   procedure Initialize (Manager : in out Probe_Manager_Type);

   --  Register the probe to handle the event identified by the given name.
   --  The event is mapped to the given id and the attributes table is used
   --  to setup the mapping from the data stream attributes.
   procedure Register_Probe (Into   : in out Probe_Manager_Type;
                             Probe  : in Probe_Type_Access;
                             Name   : in String;
                             Id     : in MAT.Events.Probe_Index_Type;
                             Model  : in MAT.Events.Const_Attribute_Table_Access);

   procedure Dispatch_Message (Client : in out Probe_Manager_Type;
                               Msg    : in out MAT.Readers.Message_Type);

   --  Read a list of event definitions from the stream and configure the reader.
   procedure Read_Event_Definitions (Client : in out Probe_Manager_Type;
                                     Msg    : in out MAT.Readers.Message_Type);

   --  Get the target events.
   function Get_Target_Events (Client : in Probe_Manager_Type)
                               return MAT.Events.Targets.Target_Events_Access;
   --  Read a message from the stream.
   procedure Read_Message (Reader : in out Probe_Manager_Type;
                           Msg    : in out MAT.Readers.Message_Type) is abstract;

   type Reader_List_Type is limited interface;
   type Reader_List_Type_Access is access all Reader_List_Type'Class;

   --  Initialize the target object to manage the memory slots, the stack frames
   --  and setup the reader to analyze the memory and other events.
   procedure Initialize (List    : in out Reader_List_Type;
                         Manager : in out Probe_Manager_Type'Class) is abstract;

private

   type Probe_Type is abstract tagged limited record
      Owner : Probe_Manager_Type_Access := null;
   end record;

   --  Record a probe
   type Probe_Handler is record
      Probe       : Probe_Type_Access;
      Id          : MAT.Events.Probe_Index_Type;
      Attributes  : MAT.Events.Const_Attribute_Table_Access;
      Mapping     : MAT.Events.Attribute_Table_Ptr;
   end record;

   function Hash (Key : in MAT.Types.Uint16) return Ada.Containers.Hash_Type;

   package Probe_Maps is
     new Ada.Containers.Indefinite_Hashed_Maps (Key_Type        => String,
                                                Element_Type    => Probe_Handler,
                                                Hash            => Ada.Strings.Hash,
                                                Equivalent_Keys => "=");

   --  Runtime handlers associated with the events.
   package Handler_Maps is
     new Ada.Containers.Hashed_Maps (Key_Type     => MAT.Types.Uint16,
                                     Element_Type => Probe_Handler,
                                     Hash         => Hash,
                                     Equivalent_Keys => "=");

   type Probe_Manager_Type is abstract new Ada.Finalization.Limited_Controlled with record
      Probes      : Probe_Maps.Map;
      Handlers    : Handler_Maps.Map;
      Version     : MAT.Types.Uint16;
      Flags       : MAT.Types.Uint16;
      Probe       : MAT.Events.Attribute_Table_Ptr;
      Frame       : access MAT.Events.Frame_Info;
      Events      : MAT.Events.Targets.Target_Events_Access;
      Event       : Target_Event_Type;
      Frames      : MAT.Frames.Frame_Type;
   end record;

   --  Read an event definition from the stream and configure the reader.
   procedure Read_Definition (Client : in out Probe_Manager_Type;
                              Msg    : in out MAT.Readers.Message);

end MAT.Events.Probes;

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

with MAT.Types;
with MAT.Events;
with MAT.Events.Targets;
with MAT.Readers;
with MAT.Frames;
package MAT.Events.Probes is

   -----------------
   --  Abstract probe definition
   -----------------
   type Probe_Type is abstract tagged limited private;
   type Probe_Type_Access is access all Probe_Type'Class;

   --  Extract the probe information from the message.
   procedure Extract (Probe  : in Probe_Type;
                      Params : in MAT.Events.Const_Attribute_Table_Access;
                      Msg    : in out MAT.Readers.Message_Type;
                      Event  : in out Target_Event_Type) is abstract;

   procedure Execute (Probe : in Probe_Type;
                      Event : in out Target_Event_Type) is abstract;

   --  Update the Size and Prev_Id information in the event identified by <tt>Id</tt>.
   --  Update the event represented by <tt>Prev_Id</tt> so that its Next_Id refers
   --  to the <tt>Id</tt> event.
   procedure Update_Event (Probe   : in Probe_Type;
                           Id      : in MAT.Events.Event_Id_Type;
                           Size    : in MAT.Types.Target_Size;
                           Prev_Id : in MAT.Events.Event_Id_Type);

   -----------------
   --  Probe Manager
   -----------------
   type Probe_Manager_Type is abstract new Ada.Finalization.Limited_Controlled with private;
   type Probe_Manager_Type_Access is access all Probe_Manager_Type'Class;

   --  Initialize the probe manager instance.
   overriding
   procedure Initialize (Manager : in out Probe_Manager_Type);

   --  Register the probe to handle the event identified by the given name.
   --  The event is mapped to the given id and the attributes table is used
   --  to setup the mapping from the data stream attributes.
   procedure Register_Probe (Into   : in out Probe_Manager_Type;
                             Probe  : in Probe_Type_Access;
                             Name   : in String;
                             Id     : in MAT.Events.Probe_Index_Type;
                             Model  : in MAT.Events.Const_Attribute_Table_Access);

   procedure Dispatch_Message (Client : in out Probe_Manager_Type;
                               Msg    : in out MAT.Readers.Message_Type);

   --  Read a list of event definitions from the stream and configure the reader.
   procedure Read_Event_Definitions (Client : in out Probe_Manager_Type;
                                     Msg    : in out MAT.Readers.Message_Type);

   --  Get the target events.
   function Get_Target_Events (Client : in Probe_Manager_Type)
                               return MAT.Events.Targets.Target_Events_Access;
   --  Read a message from the stream.
   procedure Read_Message (Reader : in out Probe_Manager_Type;
                           Msg    : in out MAT.Readers.Message_Type) is abstract;

   --  Get the size of a target address (4 or 8 bytes).
   function Get_Address_Size (Client : in Probe_Manager_Type) return MAT.Types.Target_Size;

   type Reader_List_Type is limited interface;
   type Reader_List_Type_Access is access all Reader_List_Type'Class;

   --  Initialize the target object to manage the memory slots, the stack frames
   --  and setup the reader to analyze the memory and other events.
   procedure Initialize (List    : in out Reader_List_Type;
                         Manager : in out Probe_Manager_Type'Class) is abstract;

private

   type Probe_Type is abstract tagged limited record
      Owner : Probe_Manager_Type_Access := null;
   end record;

   --  Record a probe
   type Probe_Handler is record
      Probe       : Probe_Type_Access;
      Id          : MAT.Events.Probe_Index_Type;
      Attributes  : MAT.Events.Const_Attribute_Table_Access;
      Mapping     : MAT.Events.Attribute_Table_Ptr;
   end record;

   function Hash (Key : in MAT.Types.Uint16) return Ada.Containers.Hash_Type;

   package Probe_Maps is
     new Ada.Containers.Indefinite_Hashed_Maps (Key_Type        => String,
                                                Element_Type    => Probe_Handler,
                                                Hash            => Ada.Strings.Hash,
                                                Equivalent_Keys => "=");

   --  Runtime handlers associated with the events.
   package Handler_Maps is
     new Ada.Containers.Hashed_Maps (Key_Type     => MAT.Types.Uint16,
                                     Element_Type => Probe_Handler,
                                     Hash         => Hash,
                                     Equivalent_Keys => "=");

   type Probe_Manager_Type is abstract new Ada.Finalization.Limited_Controlled with record
      Probes      : Probe_Maps.Map;
      Handlers    : Handler_Maps.Map;
      Version     : MAT.Types.Uint16;
      Flags       : MAT.Types.Uint16;
      Addr_Size   : MAT.Types.Target_Size;
      Probe       : MAT.Events.Attribute_Table_Ptr;
      Frame       : access MAT.Events.Frame_Info;
      Events      : MAT.Events.Targets.Target_Events_Access;
      Event       : Target_Event_Type;
      Frames      : MAT.Frames.Frame_Type;
   end record;

   --  Read an event definition from the stream and configure the reader.
   procedure Read_Definition (Client : in out Probe_Manager_Type;
                              Msg    : in out MAT.Readers.Message);

end MAT.Events.Probes;

Declare the Get_Address_Size function and record the target address size


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

with Util.Strings.Transforms;
package body ASF.Components.Utils.Escapes is

   --  ------------------------------
   --  Write the content that was collected by rendering the inner children.
   --  Escape the content using Javascript escape rules.
   --  ------------------------------
   procedure Write_Content (UI      : in UIEscape;
                            Writer  : in out Contexts.Writer.Response_Writer'Class;
                            Content : in String;
                            Context : in out ASF.Contexts.Faces.Faces_Context'Class) is
      pragma Unreferenced (UI, Context);

      Result : Ada.Strings.Unbounded.Unbounded_String;
      Mode   : constant String := UI.Get_Attribute (ESCAPE_MODE_NAME, Context);
   begin
      if Mode = "xml" then
         Util.Strings.Transforms.Escape_Xml (Content => Content,
                                             Into    => Result);
      else
         Util.Strings.Transforms.Escape_Java (Content => Content,
                                              Into    => Result);
      end if;
      Writer.Write (Result);
   end Write_Content;

   --  ------------------------------
   --  Encode the children components in the javascript queue.
   --  ------------------------------
   overriding
   procedure Encode_Children (UI      : in UIEscape;
                              Context : in out ASF.Contexts.Faces.Faces_Context'Class) is

      procedure Process (Content : in String);

      procedure Process (Content : in String) is
         Writer : constant Contexts.Writer.Response_Writer_Access := Context.Get_Response_Writer;
      begin
         UIEscape'Class (UI).Write_Content (Writer.all, Content, Context);
      end Process;

   begin
      UI.Wrap_Encode_Children (Context, Process'Access);
   end Encode_Children;

end ASF.Components.Utils.Escapes;

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

with Util.Strings.Transforms;
package body ASF.Components.Utils.Escapes is

   --  ------------------------------
   --  Write the content that was collected by rendering the inner children.
   --  Escape the content using Javascript escape rules.
   --  ------------------------------
   procedure Write_Content (UI      : in UIEscape;
                            Writer  : in out Contexts.Writer.Response_Writer'Class;
                            Content : in String;
                            Context : in out ASF.Contexts.Faces.Faces_Context'Class) is
      Result : Ada.Strings.Unbounded.Unbounded_String;
      Mode   : constant String := UI.Get_Attribute (ESCAPE_MODE_NAME, Context);
   begin
      if Mode = "xml" then
         Util.Strings.Transforms.Escape_Xml (Content => Content,
                                             Into    => Result);
      else
         Util.Strings.Transforms.Escape_Java (Content => Content,
                                              Into    => Result);
      end if;
      Writer.Write (Result);
   end Write_Content;

   --  ------------------------------
   --  Encode the children components in the javascript queue.
   --  ------------------------------
   overriding
   procedure Encode_Children (UI      : in UIEscape;
                              Context : in out ASF.Contexts.Faces.Faces_Context'Class) is

      procedure Process (Content : in String);

      procedure Process (Content : in String) is
         Writer : constant Contexts.Writer.Response_Writer_Access := Context.Get_Response_Writer;
      begin
         UIEscape'Class (UI).Write_Content (Writer.all, Content, Context);
      end Process;

   begin
      UI.Wrap_Encode_Children (Context, Process'Access);
   end Encode_Children;

end ASF.Components.Utils.Escapes;

Fix compilation warning

Fix compilation warning


------------------------------------------------------------------------------
--                                                                          --
--                       Copyright (C) 2016, AdaCore                        --
--                                                                          --
--  Redistribution and use in source and binary forms, with or without      --
--  modification, are permitted provided that the following conditions are  --
--  met:                                                                    --
--     1. Redistributions of source code must retain the above copyright    --
--        notice, this list of conditions and the following disclaimer.     --
--     2. Redistributions in binary form must reproduce the above copyright --
--        notice, this list of conditions and the following disclaimer in   --
--        the documentation and/or other materials provided with the        --
--        distribution.                                                     --
--     3. Neither the name of the copyright holder nor the names of its     --
--        contributors may be used to endorse or promote products derived   --
--        from this software without specific prior written permission.     --
--                                                                          --
--   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS    --
--   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT      --
--   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR  --
--   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT   --
--   HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, --
--   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT       --
--   LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,  --
--   DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY  --
--   THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT    --
--   (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE  --
--   OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.   --
--                                                                          --
------------------------------------------------------------------------------

with NRF51_SVD.TWI; use NRF51_SVD.TWI;

package body nRF51.TWI is

   ------------
   -- Enable --
   ------------

   procedure Enable (This : in out TWI_Master) is
   begin
      This.Periph.ENABLE.ENABLE := Enabled;
   end Enable;

   -------------
   -- Disable --
   -------------

   procedure Disable (This : in out TWI_Master) is
   begin
      This.Periph.ENABLE.ENABLE := Disabled;
   end Disable;

   -------------
   -- Enabled --
   -------------

   function Enabled (This : TWI_Master) return Boolean is
   begin
      return This.Periph.ENABLE.ENABLE = Enabled;
   end Enabled;

   ---------------
   -- Configure --
   ---------------

   procedure Configure
     (This     : in out TWI_Master;
      SCL, SDA : GPIO_Pin_Index;
      Speed    : TWI_Speed)
   is
   begin
      This.Periph.PSELSCL := UInt32 (SCL);
      This.Periph.PSELSDA := UInt32 (SDA);
      This.Periph.FREQUENCY := (case Speed is
                                   when TWI_100kbps => 16#0198_0000#,
                                   when TWI_250kbps => 16#0400_0000#,
                                   when TWI_400kbps => 16#0668_0000#);
   end Configure;

   ----------------
   -- Disconnect --
   ----------------

   procedure Disconnect (This : in out TWI_Master) is
   begin
      This.Periph.PSELSCL := 16#FFFF_FFFF#;
      This.Periph.PSELSDA := 16#FFFF_FFFF#;
   end Disconnect;

   ---------------------
   -- Master_Transmit --
   ---------------------

   overriding procedure Master_Transmit
     (This    : in out TWI_Master;
      Addr    : I2C_Address;
      Data    : I2C_Data;
      Status  : out I2C_Status;
      Timeout : Natural := 1000)
   is
      pragma Unreferenced (Timeout);
      Index : Integer := Data'First + 1;
   begin
      if Data'Length = 0 then
         Status := Ok;
         return;
      end if;

      --  Clear errors
      This.Periph.ERRORSRC.OVERRUN := Errorsrc_Overrun_Field_Reset;
      This.Periph.ERRORSRC.ANACK   := Errorsrc_Anack_Field_Reset;
      This.Periph.ERRORSRC.DNACK   := Errorsrc_Dnack_Field_Reset;

      --  Set Address
      This.Periph.ADDRESS.ADDRESS := UInt7 (Addr);

      --  Prepare first byte
      This.Periph.TXD.TXD := Data (Data'First);

      --  Start TX sequence
      This.Periph.TASKS_STARTTX := 1;

      loop

         loop

            if This.Periph.EVENTS_ERROR /= 0 then
               Status := Err_Error;
               --  Clear the error
               This.Periph.EVENTS_ERROR := 0;

               --  Stop sequence
               This.Periph.TASKS_STOP := 1;

               return;
            end if;

            exit when This.Periph.EVENTS_TXDSENT /= 0;
         end loop;

         --  Clear the event
         This.Periph.EVENTS_TXDSENT := 0;

         exit when Index > Data'Last;

         This.Periph.TXD.TXD := Data (Index);
         Index := Index + 1;
      end loop;

      if This.Do_Stop_Sequence then
         --  Stop sequence

         This.Periph.EVENTS_STOPPED := 0;

         This.Periph.TASKS_STOP := 1;

         while This.Periph.EVENTS_STOPPED = 0 loop
            null;
         end loop;
      end if;

      Status := Ok;
   end Master_Transmit;

   --------------------
   -- Master_Receive --
   --------------------

   overriding procedure Master_Receive
     (This    : in out TWI_Master;
      Addr    : I2C_Address;
      Data    : out I2C_Data;
      Status  : out I2C_Status;
      Timeout : Natural := 1000)
   is
      pragma Unreferenced (Timeout);
   begin
      if Data'Length = 0 then
         Status := Ok;
         return;
      end if;

      --  Clear errors
      This.Periph.ERRORSRC.OVERRUN := Clear;
      This.Periph.ERRORSRC.ANACK   := Clear;
      This.Periph.ERRORSRC.DNACK   := Clear;

      --  Set Address
      This.Periph.ADDRESS.ADDRESS := UInt7 (Addr);

      --  Start RX sequence
      This.Periph.TASKS_STARTRX := 1;

      for Elt of Data loop

         loop

            if This.Periph.EVENTS_ERROR /= 0 then
               Status := Err_Error;
               --  Clear the error
               This.Periph.EVENTS_ERROR := 0;

               --  Stop sequence
               This.Periph.TASKS_STOP := 1;

               return;
            end if;

            exit when This.Periph.EVENTS_RXDREADY /= 0;
         end loop;

         --  Clear the event
         This.Periph.EVENTS_RXDREADY := 0;

         Elt := This.Periph.RXD.RXD;
      end loop;

      if This.Do_Stop_Sequence then
         --  Stop sequence

         This.Periph.EVENTS_STOPPED := 0;

         This.Periph.TASKS_STOP := 1;

         while This.Periph.EVENTS_STOPPED = 0 loop
            null;
         end loop;
      end if;
      Status := Ok;
   end Master_Receive;

   ---------------
   -- Mem_Write --
   ---------------

   overriding procedure Mem_Write
     (This          : in out TWI_Master;
      Addr          : I2C_Address;
      Mem_Addr      : UInt16;
      Mem_Addr_Size : I2C_Memory_Address_Size;
      Data          : I2C_Data;
      Status        : out I2C_Status;
      Timeout       : Natural := 1000)
   is
   begin

      This.Do_Stop_Sequence := False;

      case Mem_Addr_Size is
         when Memory_Size_8b =>
            This.Master_Transmit (Addr    => Addr,
                                  Data    => (0 => UInt8 (Mem_Addr)),
                                  Status  => Status,
                                  Timeout => Timeout);
         when Memory_Size_16b =>
            This.Master_Transmit (Addr    => Addr,
                                  Data    => (UInt8 (Shift_Right (Mem_Addr, 8)),
                                              UInt8 (Mem_Addr and 16#FF#)),
                                  Status  => Status,
                                  Timeout => Timeout);
      end case;

      This.Do_Stop_Sequence := True;

      if Status /= Ok then
         return;
      end if;

      This.Master_Transmit (Addr    => Addr,
                            Data    => Data,
                            Status  => Status,
                            Timeout => Timeout);
   end Mem_Write;

   --------------
   -- Mem_Read --
   --------------

   overriding procedure Mem_Read
     (This          : in out TWI_Master;
      Addr          : I2C_Address;
      Mem_Addr      : UInt16;
      Mem_Addr_Size : I2C_Memory_Address_Size;
      Data          : out I2C_Data;
      Status        : out I2C_Status;
      Timeout       : Natural := 1000)
   is
   begin
      This.Do_Stop_Sequence := False;

      case Mem_Addr_Size is
         when Memory_Size_8b =>
            This.Master_Transmit (Addr    => Addr,
                                  Data    => (0 => UInt8 (Mem_Addr)),
                                  Status  => Status,
                                  Timeout => Timeout);
         when Memory_Size_16b =>
            This.Master_Transmit (Addr    => Addr,
                                  Data    => (UInt8 (Shift_Right (Mem_Addr, 8)),
                                              UInt8 (Mem_Addr and 16#FF#)),
                                  Status  => Status,
                                  Timeout => Timeout);
      end case;

      This.Do_Stop_Sequence := True;

      if Status /= Ok then
         return;
      end if;

      This.Master_Receive (Addr    => Addr,
                           Data    => Data,
                           Status  => Status,
                           Timeout => Timeout);
   end Mem_Read;

end nRF51.TWI;

------------------------------------------------------------------------------
--                                                                          --
--                       Copyright (C) 2016, AdaCore                        --
--                                                                          --
--  Redistribution and use in source and binary forms, with or without      --
--  modification, are permitted provided that the following conditions are  --
--  met:                                                                    --
--     1. Redistributions of source code must retain the above copyright    --
--        notice, this list of conditions and the following disclaimer.     --
--     2. Redistributions in binary form must reproduce the above copyright --
--        notice, this list of conditions and the following disclaimer in   --
--        the documentation and/or other materials provided with the        --
--        distribution.                                                     --
--     3. Neither the name of the copyright holder nor the names of its     --
--        contributors may be used to endorse or promote products derived   --
--        from this software without specific prior written permission.     --
--                                                                          --
--   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS    --
--   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT      --
--   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR  --
--   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT   --
--   HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, --
--   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT       --
--   LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,  --
--   DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY  --
--   THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT    --
--   (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE  --
--   OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.   --
--                                                                          --
------------------------------------------------------------------------------

with NRF51_SVD.TWI; use NRF51_SVD.TWI;

package body nRF51.TWI is

   procedure Stop_Sequence (This : in out TWI_Master'Class);

   -------------------
   -- Stop_Sequence --
   -------------------

   procedure Stop_Sequence (This : in out TWI_Master'Class) is
   begin
      --  Stop sequence

      This.Periph.EVENTS_STOPPED := 0;

      This.Periph.TASKS_STOP := 1;

      while This.Periph.EVENTS_STOPPED = 0 loop
         null;
      end loop;
   end Stop_Sequence;

   ------------
   -- Enable --
   ------------

   procedure Enable (This : in out TWI_Master) is
   begin
      This.Periph.ENABLE.ENABLE := Enabled;
   end Enable;

   -------------
   -- Disable --
   -------------

   procedure Disable (This : in out TWI_Master) is
   begin
      This.Periph.ENABLE.ENABLE := Disabled;
   end Disable;

   -------------
   -- Enabled --
   -------------

   function Enabled (This : TWI_Master) return Boolean is
   begin
      return This.Periph.ENABLE.ENABLE = Enabled;
   end Enabled;

   ---------------
   -- Configure --
   ---------------

   procedure Configure
     (This     : in out TWI_Master;
      SCL, SDA : GPIO_Pin_Index;
      Speed    : TWI_Speed)
   is
   begin
      This.Periph.PSELSCL := UInt32 (SCL);
      This.Periph.PSELSDA := UInt32 (SDA);
      This.Periph.FREQUENCY := (case Speed is
                                   when TWI_100kbps => 16#0198_0000#,
                                   when TWI_250kbps => 16#0400_0000#,
                                   when TWI_400kbps => 16#0668_0000#);
   end Configure;

   ----------------
   -- Disconnect --
   ----------------

   procedure Disconnect (This : in out TWI_Master) is
   begin
      This.Periph.PSELSCL := 16#FFFF_FFFF#;
      This.Periph.PSELSDA := 16#FFFF_FFFF#;
   end Disconnect;

   ---------------------
   -- Master_Transmit --
   ---------------------

   overriding procedure Master_Transmit
     (This    : in out TWI_Master;
      Addr    : I2C_Address;
      Data    : I2C_Data;
      Status  : out I2C_Status;
      Timeout : Natural := 1000)
   is
      pragma Unreferenced (Timeout);
      Index : Integer := Data'First + 1;
   begin
      if Data'Length = 0 then
         Status := Ok;
         return;
      end if;

      --  Clear errors
      This.Periph.ERRORSRC.OVERRUN := Errorsrc_Overrun_Field_Reset;
      This.Periph.ERRORSRC.ANACK   := Errorsrc_Anack_Field_Reset;
      This.Periph.ERRORSRC.DNACK   := Errorsrc_Dnack_Field_Reset;

      --  Set Address
      This.Periph.ADDRESS.ADDRESS := UInt7 (Addr);

      --  Prepare first byte
      This.Periph.TXD.TXD := Data (Data'First);

      --  Start TX sequence
      This.Periph.TASKS_STARTTX := 1;

      loop

         loop

            if This.Periph.EVENTS_ERROR /= 0 then
               Status := Err_Error;
               --  Clear the error
               This.Periph.EVENTS_ERROR := 0;

               --  Stop sequence
               This.Periph.TASKS_STOP := 1;

               return;
            end if;

            exit when This.Periph.EVENTS_TXDSENT /= 0;
         end loop;

         --  Clear the event
         This.Periph.EVENTS_TXDSENT := 0;

         exit when Index > Data'Last;

         This.Periph.TXD.TXD := Data (Index);
         Index := Index + 1;
      end loop;

      if This.Do_Stop_Sequence then
         Stop_Sequence (This);
      end if;

      Status := Ok;
   end Master_Transmit;

   --------------------
   -- Master_Receive --
   --------------------

   overriding procedure Master_Receive
     (This    : in out TWI_Master;
      Addr    : I2C_Address;
      Data    : out I2C_Data;
      Status  : out I2C_Status;
      Timeout : Natural := 1000)
   is
      pragma Unreferenced (Timeout);
   begin
      if Data'Length = 0 then
         Status := Ok;
         return;
      end if;

      --  Clear errors
      This.Periph.ERRORSRC.OVERRUN := Clear;
      This.Periph.ERRORSRC.ANACK   := Clear;
      This.Periph.ERRORSRC.DNACK   := Clear;

      --  Set Address
      This.Periph.ADDRESS.ADDRESS := UInt7 (Addr);

      --  Configure SHORTS to automatically suspend TWI port when receiving a
      --  byte.
      This.Periph.SHORTS.BB_SUSPEND := Enabled;
      This.Periph.SHORTS.BB_STOP    := Disabled;

      --  Start RX sequence
      This.Periph.TASKS_STARTRX := 1;

      for Index in Data'Range loop

         loop

            if This.Periph.EVENTS_ERROR /= 0 then
               Status := Err_Error;
               --  Clear the error
               This.Periph.EVENTS_ERROR := 0;

               Stop_Sequence (This);

               return;
            end if;

            exit when This.Periph.EVENTS_RXDREADY /= 0;
         end loop;

         if Index = Data'Last and then This.Do_Stop_Sequence then

            --  Configure SHORTS to automatically stop the TWI port and produce
            --  a STOP event on the bus when receiving a byte.
            This.Periph.SHORTS.BB_SUSPEND := Disabled;
            This.Periph.SHORTS.BB_STOP    := Enabled;
         end if;

         --  Clear the event
         This.Periph.EVENTS_RXDREADY := 0;

         Data (Index) := This.Periph.RXD.RXD;
      end loop;

      Status := Ok;
   end Master_Receive;

   ---------------
   -- Mem_Write --
   ---------------

   overriding procedure Mem_Write
     (This          : in out TWI_Master;
      Addr          : I2C_Address;
      Mem_Addr      : UInt16;
      Mem_Addr_Size : I2C_Memory_Address_Size;
      Data          : I2C_Data;
      Status        : out I2C_Status;
      Timeout       : Natural := 1000)
   is
   begin

      This.Do_Stop_Sequence := False;

      case Mem_Addr_Size is
         when Memory_Size_8b =>
            This.Master_Transmit (Addr    => Addr,
                                  Data    => (0 => UInt8 (Mem_Addr)),
                                  Status  => Status,
                                  Timeout => Timeout);
         when Memory_Size_16b =>
            This.Master_Transmit (Addr    => Addr,
                                  Data    => (UInt8 (Shift_Right (Mem_Addr, 8)),
                                              UInt8 (Mem_Addr and 16#FF#)),
                                  Status  => Status,
                                  Timeout => Timeout);
      end case;

      This.Do_Stop_Sequence := True;

      if Status /= Ok then
         return;
      end if;

      This.Master_Transmit (Addr    => Addr,
                            Data    => Data,
                            Status  => Status,
                            Timeout => Timeout);
   end Mem_Write;

   --------------
   -- Mem_Read --
   --------------

   overriding procedure Mem_Read
     (This          : in out TWI_Master;
      Addr          : I2C_Address;
      Mem_Addr      : UInt16;
      Mem_Addr_Size : I2C_Memory_Address_Size;
      Data          : out I2C_Data;
      Status        : out I2C_Status;
      Timeout       : Natural := 1000)
   is
   begin
      This.Do_Stop_Sequence := False;

      case Mem_Addr_Size is
         when Memory_Size_8b =>
            This.Master_Transmit (Addr    => Addr,
                                  Data    => (0 => UInt8 (Mem_Addr)),
                                  Status  => Status,
                                  Timeout => Timeout);
         when Memory_Size_16b =>
            This.Master_Transmit (Addr    => Addr,
                                  Data    => (UInt8 (Shift_Right (Mem_Addr, 8)),
                                              UInt8 (Mem_Addr and 16#FF#)),
                                  Status  => Status,
                                  Timeout => Timeout);
      end case;

      This.Do_Stop_Sequence := True;

      if Status /= Ok then
         return;
      end if;

      This.Master_Receive (Addr    => Addr,
                           Data    => Data,
                           Status  => Status,
                           Timeout => Timeout);
   end Mem_Read;

end nRF51.TWI;

Fix Master_Receive

nRF51.TWI: Fix Master_Receive

The stop sequence was generated one byte too late.


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

with Util.Test_Caller;

with ADO.Sessions;
with ADO.Schemas.Entities;

with Regtests;
with Regtests.Simple.Model;
package body ADO.Schemas.Tests is

   use Util.Tests;

   package Caller is new Util.Test_Caller (Test, "ADO.Schemas");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test ADO.Schemas.Entities.Find_Entity_Type",
                       Test_Find_Entity_Type'Access);
      Caller.Add_Test (Suite, "Test ADO.Schemas.Entities.Find_Entity_Type (error)",
                       Test_Find_Entity_Type_Error'Access);
      Caller.Add_Test (Suite, "Test ADO.Sessions.Load_Schema",
                       Test_Load_Schema'Access);
      Caller.Add_Test (Suite, "Test ADO.Schemas.Get_Table",
                       Test_Table_Iterator'Access);
      Caller.Add_Test (Suite, "Test ADO.Schemas.Get_Table (Empty schema)",
                       Test_Empty_Schema'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test reading the entity cache and the Find_Entity_Type operation
   --  ------------------------------
   procedure Test_Find_Entity_Type (T : in out Test) is
      S   : ADO.Sessions.Session := Regtests.Get_Database;
      C   : ADO.Schemas.Entities.Entity_Cache;
   begin
      ADO.Schemas.Entities.Initialize (Cache   => C,
                                       Session => S);

      declare
--           T1 : constant ADO.Model.Entity_Type_Ref
--             := Entities.Find_Entity_Type (Cache => C,
--                                           Table => Regtests.Simple.Model.USER_TABLE'Access);
--           T2 : constant ADO.Model.Entity_Type_Ref
--             := Entities.Find_Entity_Type (Cache => C,
--                                           Table => Regtests.Simple.Model.ALLOCATE_TABLE'Access);

         T4 : constant ADO.Entity_Type
           := Entities.Find_Entity_Type (Cache => C,
                                         Table => Regtests.Simple.Model.ALLOCATE_TABLE);
         T5 : constant ADO.Entity_Type
           := Entities.Find_Entity_Type (Cache => C,
                                         Table => Regtests.Simple.Model.USER_TABLE);
      begin
--           T.Assert (not ADO.Objects.Is_Null (T1), "Find_Entity_Type returned a null value");
--           T.Assert (not ADO.Objects.Is_Null (T2), "Find_Entity_Type returned a null value");

         T.Assert (T4 /= T5, "Two distinct tables have different entity types");
         T.Assert (T4 > 0, "T1.Id must be positive");
         T.Assert (T5 > 0, "T2.Id must be positive");
--           T.Assert (T1.Get_Id /= T2.Get_Id, "Two distinct tables have different ids");
--
--           Assert_Equals (T, Integer (T2.Get_Id), Integer (T4),
--                          "Invalid entity type for allocate_table");
--           Assert_Equals (T, Integer (T1.Get_Id), Integer (T5),
--                          "Invalid entity type for user_table");
      end;
   end Test_Find_Entity_Type;

   --  ------------------------------
   --  Test calling Find_Entity_Type with an invalid table.
   --  ------------------------------
   procedure Test_Find_Entity_Type_Error (T : in out Test) is
      C   : ADO.Schemas.Entities.Entity_Cache;
   begin
      declare
         R : ADO.Entity_Type;
         pragma Unreferenced (R);
      begin
         R := Entities.Find_Entity_Type (Cache => C,
                                         Table => Regtests.Simple.Model.USER_TABLE);
         T.Assert (False, "Find_Entity_Type did not raise the No_Entity_Type exception");

      exception
         when ADO.Schemas.Entities.No_Entity_Type =>
            null;
      end;
   end Test_Find_Entity_Type_Error;

   --  ------------------------------
   --  Test the Load_Schema operation and check the result schema.
   --  ------------------------------
   procedure Test_Load_Schema (T : in out Test) is
      S      : constant ADO.Sessions.Session := Regtests.Get_Database;
      Schema : Schema_Definition;
      Table  : Table_Definition;
   begin
      S.Load_Schema (Schema);

      Table := ADO.Schemas.Find_Table (Schema, "allocate");
      T.Assert (Table /= null, "Table schema for test_allocate not found");

      Assert_Equals (T, "allocate", Get_Name (Table));

      declare
         C : Column_Cursor := Get_Columns (Table);
         Nb_Columns : Integer := 0;
      begin
         while Has_Element (C) loop
            Nb_Columns := Nb_Columns + 1;
            Next (C);
         end loop;
         Assert_Equals (T, 3, Nb_Columns, "Invalid number of columns");
      end;

      declare
         C : constant Column_Definition := Find_Column (Table, "ID");
      begin
         T.Assert (C /= null, "Cannot find column 'id' in table schema");
         Assert_Equals (T, "ID", Get_Name (C), "Invalid column name");
         T.Assert (Get_Type (C) = T_LONG_INTEGER, "Invalid column type");
         T.Assert (not Is_Null (C), "Column is null");
      end;

      declare
         C : constant Column_Definition := Find_Column (Table, "NAME");
      begin
         T.Assert (C /= null, "Cannot find column 'NAME' in table schema");
         Assert_Equals (T, "NAME", Get_Name (C), "Invalid column name");
         T.Assert (Get_Type (C) = T_VARCHAR, "Invalid column type");
         T.Assert (Is_Null (C), "Column is null");
      end;

      declare
         C : constant Column_Definition := Find_Column (Table, "version");
      begin
         T.Assert (C /= null, "Cannot find column 'version' in table schema");
         Assert_Equals (T, "version", Get_Name (C), "Invalid column name");
         T.Assert (Get_Type (C) = T_INTEGER, "Invalid column type");
         T.Assert (not Is_Null (C), "Column is null");
      end;

      declare
         C : constant Column_Definition := Find_Column (Table, "this_column_does_not_exist");
      begin
         T.Assert (C = null, "Find_Column must return null for an unknown column");
      end;
   end Test_Load_Schema;

   --  ------------------------------
   --  Test the Table_Cursor operations and check the result schema.
   --  ------------------------------
   procedure Test_Table_Iterator (T : in out Test) is
      S      : constant ADO.Sessions.Session := Regtests.Get_Database;
      Schema : Schema_Definition;
      Table  : Table_Definition;
      Driver : constant String := S.Get_Connection.Get_Driver.Get_Driver_Name;
   begin
      S.Load_Schema (Schema);

      declare
         Iter  : Table_Cursor := Schema.Get_Tables;
         Count : Natural := 0;
      begin
         T.Assert (Has_Element (Iter), "The Get_Tables returns an empty iterator");
         while Has_Element (Iter) loop
            Table := Element (Iter);
            T.Assert (Table /= null, "Element function must not return null");
            declare
               Col_Iter : Column_Cursor := Get_Columns (Table);
            begin
               --  T.Assert (Has_Element (Col_Iter), "Table has a column");
               while Has_Element (Col_Iter) loop
                  T.Assert (Element (Col_Iter) /= null, "Element function must not return null");
                  Next (Col_Iter);
               end loop;
            end;
            Count := Count + 1;
            Next (Iter);
         end loop;
         if Driver = "sqlite" then
            Util.Tests.Assert_Equals (T, 15, Count,
                                      "Invalid number of tables found in the schema");
         elsif Driver = "mysql" then
            Util.Tests.Assert_Equals (T, 8, Count,
                                      "Invalid number of tables found in the schema");
         end if;
      end;
   end Test_Table_Iterator;

   --  ------------------------------
   --  Test the Table_Cursor operations on an empty schema.
   --  ------------------------------
   procedure Test_Empty_Schema (T : in out Test) is
      Schema : Schema_Definition;
      Iter   : constant Table_Cursor := Schema.Get_Tables;
   begin
      T.Assert (not Has_Element (Iter), "The Get_Tables must return an empty iterator");
      T.Assert (Schema.Find_Table ("test") = null, "The Find_Table must return null");
   end Test_Empty_Schema;

end ADO.Schemas.Tests;

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

with Util.Test_Caller;

with ADO.Sessions;
with ADO.Schemas.Entities;

with Regtests;
with Regtests.Simple.Model;
package body ADO.Schemas.Tests is

   use Util.Tests;

   package Caller is new Util.Test_Caller (Test, "ADO.Schemas");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test ADO.Schemas.Entities.Find_Entity_Type",
                       Test_Find_Entity_Type'Access);
      Caller.Add_Test (Suite, "Test ADO.Schemas.Entities.Find_Entity_Type (error)",
                       Test_Find_Entity_Type_Error'Access);
      Caller.Add_Test (Suite, "Test ADO.Sessions.Load_Schema",
                       Test_Load_Schema'Access);
      Caller.Add_Test (Suite, "Test ADO.Schemas.Get_Table",
                       Test_Table_Iterator'Access);
      Caller.Add_Test (Suite, "Test ADO.Schemas.Get_Table (Empty schema)",
                       Test_Empty_Schema'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test reading the entity cache and the Find_Entity_Type operation
   --  ------------------------------
   procedure Test_Find_Entity_Type (T : in out Test) is
      S   : ADO.Sessions.Session := Regtests.Get_Database;
      C   : ADO.Schemas.Entities.Entity_Cache;
   begin
      ADO.Schemas.Entities.Initialize (Cache   => C,
                                       Session => S);

      declare
--           T1 : constant ADO.Model.Entity_Type_Ref
--             := Entities.Find_Entity_Type (Cache => C,
--                                           Table => Regtests.Simple.Model.USER_TABLE'Access);
--           T2 : constant ADO.Model.Entity_Type_Ref
--             := Entities.Find_Entity_Type (Cache => C,
--                                           Table => Regtests.Simple.Model.ALLOCATE_TABLE'Access);

         T4 : constant ADO.Entity_Type
           := Entities.Find_Entity_Type (Cache => C,
                                         Table => Regtests.Simple.Model.ALLOCATE_TABLE);
         T5 : constant ADO.Entity_Type
           := Entities.Find_Entity_Type (Cache => C,
                                         Table => Regtests.Simple.Model.USER_TABLE);
      begin
--           T.Assert (not ADO.Objects.Is_Null (T1), "Find_Entity_Type returned a null value");
--           T.Assert (not ADO.Objects.Is_Null (T2), "Find_Entity_Type returned a null value");

         T.Assert (T4 /= T5, "Two distinct tables have different entity types");
         T.Assert (T4 > 0, "T1.Id must be positive");
         T.Assert (T5 > 0, "T2.Id must be positive");
--           T.Assert (T1.Get_Id /= T2.Get_Id, "Two distinct tables have different ids");
--
--           Assert_Equals (T, Integer (T2.Get_Id), Integer (T4),
--                          "Invalid entity type for allocate_table");
--           Assert_Equals (T, Integer (T1.Get_Id), Integer (T5),
--                          "Invalid entity type for user_table");
      end;
   end Test_Find_Entity_Type;

   --  ------------------------------
   --  Test calling Find_Entity_Type with an invalid table.
   --  ------------------------------
   procedure Test_Find_Entity_Type_Error (T : in out Test) is
      C   : ADO.Schemas.Entities.Entity_Cache;
   begin
      declare
         R : ADO.Entity_Type;
         pragma Unreferenced (R);
      begin
         R := Entities.Find_Entity_Type (Cache => C,
                                         Table => Regtests.Simple.Model.USER_TABLE);
         T.Assert (False, "Find_Entity_Type did not raise the No_Entity_Type exception");

      exception
         when ADO.Schemas.Entities.No_Entity_Type =>
            null;
      end;
   end Test_Find_Entity_Type_Error;

   --  ------------------------------
   --  Test the Load_Schema operation and check the result schema.
   --  ------------------------------
   procedure Test_Load_Schema (T : in out Test) is
      S      : constant ADO.Sessions.Session := Regtests.Get_Database;
      Schema : Schema_Definition;
      Table  : Table_Definition;
   begin
      S.Load_Schema (Schema);

      Table := ADO.Schemas.Find_Table (Schema, "allocate");
      T.Assert (Table /= null, "Table schema for test_allocate not found");

      Assert_Equals (T, "allocate", Get_Name (Table));

      declare
         C : Column_Cursor := Get_Columns (Table);
         Nb_Columns : Integer := 0;
      begin
         while Has_Element (C) loop
            Nb_Columns := Nb_Columns + 1;
            Next (C);
         end loop;
         Assert_Equals (T, 3, Nb_Columns, "Invalid number of columns");
      end;

      declare
         C : constant Column_Definition := Find_Column (Table, "ID");
      begin
         T.Assert (C /= null, "Cannot find column 'id' in table schema");
         Assert_Equals (T, "ID", Get_Name (C), "Invalid column name");
         T.Assert (Get_Type (C) = T_LONG_INTEGER, "Invalid column type");
         T.Assert (not Is_Null (C), "Column is null");
      end;

      declare
         C : constant Column_Definition := Find_Column (Table, "NAME");
      begin
         T.Assert (C /= null, "Cannot find column 'NAME' in table schema");
         Assert_Equals (T, "NAME", Get_Name (C), "Invalid column name");
         T.Assert (Get_Type (C) = T_VARCHAR, "Invalid column type");
         T.Assert (Is_Null (C), "Column is null");
      end;

      declare
         C : constant Column_Definition := Find_Column (Table, "version");
      begin
         T.Assert (C /= null, "Cannot find column 'version' in table schema");
         Assert_Equals (T, "version", Get_Name (C), "Invalid column name");
         T.Assert (Get_Type (C) = T_INTEGER, "Invalid column type");
         T.Assert (not Is_Null (C), "Column is null");
      end;

      declare
         C : constant Column_Definition := Find_Column (Table, "this_column_does_not_exist");
      begin
         T.Assert (C = null, "Find_Column must return null for an unknown column");
      end;
   end Test_Load_Schema;

   --  ------------------------------
   --  Test the Table_Cursor operations and check the result schema.
   --  ------------------------------
   procedure Test_Table_Iterator (T : in out Test) is
      S      : constant ADO.Sessions.Session := Regtests.Get_Database;
      Schema : Schema_Definition;
      Table  : Table_Definition;
      Driver : constant String := S.Get_Driver.Get_Driver_Name;
   begin
      S.Load_Schema (Schema);

      declare
         Iter  : Table_Cursor := Schema.Get_Tables;
         Count : Natural := 0;
      begin
         T.Assert (Has_Element (Iter), "The Get_Tables returns an empty iterator");
         while Has_Element (Iter) loop
            Table := Element (Iter);
            T.Assert (Table /= null, "Element function must not return null");
            declare
               Col_Iter : Column_Cursor := Get_Columns (Table);
            begin
               --  T.Assert (Has_Element (Col_Iter), "Table has a column");
               while Has_Element (Col_Iter) loop
                  T.Assert (Element (Col_Iter) /= null, "Element function must not return null");
                  Next (Col_Iter);
               end loop;
            end;
            Count := Count + 1;
            Next (Iter);
         end loop;
         if Driver = "sqlite" then
            Util.Tests.Assert_Equals (T, 15, Count,
                                      "Invalid number of tables found in the schema");
         elsif Driver = "mysql" then
            Util.Tests.Assert_Equals (T, 8, Count,
                                      "Invalid number of tables found in the schema");
         end if;
      end;
   end Test_Table_Iterator;

   --  ------------------------------
   --  Test the Table_Cursor operations on an empty schema.
   --  ------------------------------
   procedure Test_Empty_Schema (T : in out Test) is
      Schema : Schema_Definition;
      Iter   : constant Table_Cursor := Schema.Get_Tables;
   begin
      T.Assert (not Has_Element (Iter), "The Get_Tables must return an empty iterator");
      T.Assert (Schema.Find_Table ("test") = null, "The Find_Table must return null");
   end Test_Empty_Schema;

end ADO.Schemas.Tests;

Update the unit test

Update the unit test