-----------------------------------------------------------------------
--  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


-----------------------------------------------------------------------
--  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


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

package body Util.Dates.ISO8601 is

   --  ------------------------------
   --  Parses an ISO8601 date and return it as a calendar time.
   --  Raises Constraint_Error if the date format is not recognized.
   --  ------------------------------
   function Value (Date : in String) return Ada.Calendar.Time is
      use Ada.Calendar;

      Result : Date_Record;
   begin
      if Date'Length < 4 then
         raise Constraint_Error with "Invalid date";
      end if;
      Result.Year := Year_Number'Value (Date (Date'First .. Date'First + 3));
      if Date'Length = 4 then
         --  ISO8601 date: YYYY
         Result.Month := 1;
         Result.Month_Day := 1;

      elsif Date'Length = 7 and Date (Date'First + 4) = '-' then
         --  ISO8601 date: YYYY-MM
         Result.Month := Month_Number'Value (Date (Date'First + 4 .. Date'Last));
         Result.Month_Day := 1;

      elsif Date'Length = 8 then
         --  ISO8601 date: YYYYMMDD
         Result.Month := Month_Number'Value (Date (Date'First + 4 .. Date'First + 5));
         Result.Month_Day := Day_Number'Value (Date (Date'First + 6 .. Date'First + 7));

      elsif Date'Length >= 9 and then Date (Date'First + 4) = '-'
        and then Date (Date'First + 7) = '-'
      then
         --  ISO8601 date: YYYY-MM-DD
         Result.Month := Month_Number'Value (Date (Date'First + 5 .. Date'First + 6));
         Result.Month_Day := Day_Number'Value (Date (Date'First + 8 .. Date'First + 9));

      else
         raise Constraint_Error with "invalid date";
      end if;
      return Ada.Calendar.Formatting.Time_Of (Year        => Result.Year,
                                              Month       => Result.Month,
                                              Day         => Result.Month_Day,
                                              Hour        => 0,
                                              Minute      => 0,
                                              Second      => 0,
                                              Sub_Second  => 0.0);
   end Value;

   --  ------------------------------
   --  Return the ISO8601 date.
   --  ------------------------------
   function Image (Date : in Ada.Calendar.Time) return String is
      D : Date_Record;
   begin
      Split (D, Date);
      return Image (D);
   end Image;

   function Image (Date : in Date_Record) return String is
      To_Char : constant array (0 .. 9) of Character := "0123456789";
      Result  : String (1 .. 10) := "0000-00-00";
   begin
      Result (1) := To_Char (Date.Year / 1000);
      Result (2) := To_Char (Date.Year / 100 mod 10);
      Result (3) := To_Char (Date.Year / 10 mod 10);
      Result (4) := To_Char (Date.Year mod 10);
      Result (6) := To_Char (Date.Month / 10);
      Result (7) := To_Char (Date.Month mod 10);
      Result (9) := To_Char (Date.Month_Day / 10);
      Result (10) := To_Char (Date.Month_Day mod 10);
      return Result;
   end Image;

end Util.Dates.ISO8601;

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

package body Util.Dates.ISO8601 is

   --  ------------------------------
   --  Parses an ISO8601 date and return it as a calendar time.
   --  Raises Constraint_Error if the date format is not recognized.
   --  ------------------------------
   function Value (Date : in String) return Ada.Calendar.Time is
      use Ada.Calendar;
      use Ada.Calendar.Formatting;

      Result : Date_Record;
      Pos    : Natural;
   begin
      if Date'Length < 4 then
         raise Constraint_Error with "Invalid date";
      end if;
      Result.Hour       := 0;
      Result.Minute     := 0;
      Result.Second     := 0;
      Result.Sub_Second := 0.0;
      Result.Time_Zone  := 0;
      Result.Year := Year_Number'Value (Date (Date'First .. Date'First + 3));
      if Date'Length = 4 then
         --  ISO8601 date: YYYY
         Result.Month := 1;
         Result.Month_Day := 1;

      elsif Date'Length = 7 and Date (Date'First + 4) = '-' then
         --  ISO8601 date: YYYY-MM
         Result.Month := Month_Number'Value (Date (Date'First + 4 .. Date'Last));
         Result.Month_Day := 1;

      elsif Date'Length = 8 then
         --  ISO8601 date: YYYYMMDD
         Result.Month := Month_Number'Value (Date (Date'First + 4 .. Date'First + 5));
         Result.Month_Day := Day_Number'Value (Date (Date'First + 6 .. Date'First + 7));

      elsif Date'Length >= 9 and then Date (Date'First + 4) = '-'
        and then Date (Date'First + 7) = '-'
      then
         --  ISO8601 date: YYYY-MM-DD
         Result.Month := Month_Number'Value (Date (Date'First + 5 .. Date'First + 6));
         Result.Month_Day := Day_Number'Value (Date (Date'First + 8 .. Date'First + 9));

         --  ISO8601 date: YYYY-MM-DDTHH
         if Date'Length > 12 then
            if Date (Date'First + 10) /= 'T' then
               raise Constraint_Error with "invalid date";
            end if;
            Result.Hour := Hour_Number'Value (Date (Date'First + 11 .. Date'First + 12));
            Pos := Date'First + 13;
         end if;
         if Date'Length > 15 then
            if Date (Date'First + 13) /= ':' then
               raise Constraint_Error with "invalid date";
            end if;
            Result.Minute := Minute_Number'Value (Date (Date'First + 14 .. Date'First + 15));
            Pos := Date'First + 16;
         end if;
         if Date'Length > 18 then
            if Date (Date'First + 16) /= ':' then
               raise Constraint_Error with "invalid date";
            end if;
            Result.Second := Second_Number'Value (Date (Date'First + 17 .. Date'First + 18));
            Pos := Date'First + 19;
         end if;

         --  ISO8601 timezone: +hh:mm or -hh:mm
--           if Date'Length > Pos + 4 then
--              if Date (Pos) /= '+' and Date (Pos) /= '-' and Date (Pos + 2) /= ':' then
--                 raise Constraint_Error with "invalid date";
--              end if;
--           end if;
      else
         raise Constraint_Error with "invalid date";
      end if;
      return Ada.Calendar.Formatting.Time_Of (Year        => Result.Year,
                                              Month       => Result.Month,
                                              Day         => Result.Month_Day,
                                              Hour        => Result.Hour,
                                              Minute      => Result.Minute,
                                              Second      => Result.Second,
                                              Sub_Second  => Result.Sub_Second,
                                              Time_Zone   => Result.Time_Zone);
   end Value;

   --  ------------------------------
   --  Return the ISO8601 date.
   --  ------------------------------
   function Image (Date : in Ada.Calendar.Time) return String is
      D : Date_Record;
   begin
      Split (D, Date);
      return Image (D);
   end Image;

   function Image (Date : in Date_Record) return String is
      To_Char : constant array (0 .. 9) of Character := "0123456789";
      Result  : String (1 .. 10) := "0000-00-00";
   begin
      Result (1) := To_Char (Date.Year / 1000);
      Result (2) := To_Char (Date.Year / 100 mod 10);
      Result (3) := To_Char (Date.Year / 10 mod 10);
      Result (4) := To_Char (Date.Year mod 10);
      Result (6) := To_Char (Date.Month / 10);
      Result (7) := To_Char (Date.Month mod 10);
      Result (9) := To_Char (Date.Month_Day / 10);
      Result (10) := To_Char (Date.Month_Day mod 10);
      return Result;
   end Image;

   function Image (Date      : in Ada.Calendar.Time;
                   Precision : in Precision_Type) return String is
      D : Date_Record;
   begin
      Split (D, Date);
      return Image (D, Precision);
   end Image;

   function Image (Date      : in Date_Record;
                   Precision : in Precision_Type) return String is
      use type Ada.Calendar.Time_Zones.Time_Offset;

      To_Char : constant array (0 .. 9) of Character := "0123456789";
      Result  : String (1 .. 29) := "0000-00-00T00:00:00.000-00:00";
     N,  Tz      : Natural;
   begin
      Result (1) := To_Char (Date.Year / 1000);
      Result (2) := To_Char (Date.Year / 100 mod 10);
      Result (3) := To_Char (Date.Year / 10 mod 10);
      Result (4) := To_Char (Date.Year mod 10);
      if Precision = YEAR then
         return Result (1 .. 4);
      end if;
      Result (6) := To_Char (Date.Month / 10);
      Result (7) := To_Char (Date.Month mod 10);
      if Precision = MONTH then
         return Result (1 .. 7);
      end if;
      Result (9) := To_Char (Date.Month_Day / 10);
      Result (10) := To_Char (Date.Month_Day mod 10);
      if Precision = DAY then
         return Result (1 .. 10);
      end if;
      Result (12) := To_Char (Date.Hour / 10);
      Result (13) := To_Char (Date.Hour mod 10);
      if Precision = HOUR then
         return Result (1 .. 13);
      end if;
      Result (15) := To_Char (Date.Minute / 10);
      Result (16) := To_Char (Date.Minute mod 10);
      if Precision = MINUTE then
         return Result (1 .. 16);
      end if;
      Result (18) := To_Char (Date.Second / 10);
      Result (19) := To_Char (Date.Second mod 10);
      if Precision = SECOND then
         return Result (1 .. 19);
      end if;
      N := Natural (Date.Sub_Second * 1000.0);
      Result (21) := To_Char (N / 100);
      Result (22) := To_Char ((N mod 100) / 10);
      Result (23) := To_Char (N mod 10);
      if Date.Time_Zone < 0 then
         Tz := Natural (-Date.Time_Zone);
      else
         Result (24) := '+';
         Tz := Natural (Date.Time_Zone);
      end if;
      Result (25) := To_Char (Tz / 600);
      Result (26) := To_Char ((Tz / 60) mod 10);
      Tz := Tz mod 60;
      Result (28) := To_Char (Tz / 10);
      Result (29) := To_Char (Tz mod 10);
      return Result;
   end Image;

end Util.Dates.ISO8601;

Implement new Image operation with several precision format for the date


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

with Ada.Strings.Unbounded;

with Util.Test_Caller;
package body Security.Random.Tests is

   package Caller is new Util.Test_Caller (Test, "Security.Random");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Security.Random.Generate",
                       Test_Generate'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test Yadis discovery using static files
   --  ------------------------------
   procedure Test_Generate (T : in out Test) is
      use Ada.Strings.Unbounded;

      G   : Generator;
      Max : constant Ada.Streams.Stream_Element_Offset := 10;
   begin
      for I in 1 .. Max loop
         declare
            use type Ada.Streams.Stream_Element;
            S : Ada.Streams.Stream_Element_Array (1 .. I)
              := (others => 0);
            Rand : Ada.Strings.Unbounded.Unbounded_String;
         begin
            --  Try 5 times to fill the array with random patterns and make sure
            --  we don't get any 0.
            for Retry in 1 .. 5 loop
               G.Generate (S);
               exit when (for all R of S => R /= 0);
            end loop;
            T.Assert ((for all R of S => R /= 0), "Generator failed to initialize all bytes");

            G.Generate (Positive (I), Rand);
            T.Assert (Length (Rand) > 0, "Generator failed to produce a base64url sequence");
         end;
      end loop;
   end Test_Generate;

end Security.Random.Tests;

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

with Ada.Strings.Unbounded;

with Util.Test_Caller;
package body Security.Random.Tests is

   package Caller is new Util.Test_Caller (Test, "Security.Random");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Security.Random.Generate",
                       Test_Generate'Access);
      Caller.Add_Test (Suite, "Test Security.Random.Generate_String",
                       Test_Generate_String'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test Yadis discovery using static files
   --  ------------------------------
   procedure Test_Generate (T : in out Test) is
      use Ada.Strings.Unbounded;

      G   : Generator;
      Max : constant Ada.Streams.Stream_Element_Offset := 10;
   begin
      for I in 1 .. Max loop
         declare
            use type Ada.Streams.Stream_Element;
            S : Ada.Streams.Stream_Element_Array (1 .. I)
              := (others => 0);
            Rand : Ada.Strings.Unbounded.Unbounded_String;
         begin
            --  Try 5 times to fill the array with random patterns and make sure
            --  we don't get any 0.
            for Retry in 1 .. 5 loop
               G.Generate (S);
               exit when (for all R of S => R /= 0);
            end loop;
            T.Assert ((for all R of S => R /= 0), "Generator failed to initialize all bytes");

            G.Generate (Positive (I), Rand);
            T.Assert (Length (Rand) > 0, "Generator failed to produce a base64url sequence");
         end;
      end loop;
   end Test_Generate;

   procedure Test_Generate_String (T : in out Test) is
      G   : Generator;
   begin
      declare
         S1 : constant String := G.Generate (Bits => 256);
         S2 : constant String := G.Generate (Bits => 256);
      begin
         Util.Tests.Assert_Equals (T, 43, Natural (S1'Length),
                                   "Generated string 1 is too small");
         Util.Tests.Assert_Equals (T, 43, Natural (S2'Length),
                                   "Generated string 2 is too small");
         T.Assert (S1 /= S2, "Generated string are equal");
      end;
   end Test_Generate_String;

end Security.Random.Tests;

Add Test_Generate_String to check the length of random string


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

with Util.Test_Caller;

with Util.Strings.Transforms;
with Util.Http.Tools;
with Util.Strings;
with Util.Log.Loggers;

package body Util.Http.Clients.Tests is

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Util.Http.Clients.Tests");

   package body Http_Tests is
      package Caller is new Util.Test_Caller (Http_Test, "Http-" & NAME);

      procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
      begin
         Caller.Add_Test (Suite, "Test Util.Http.Clients." & NAME & ".Get",
                          Test_Http_Get'Access);
         Caller.Add_Test (Suite, "Test Util.Http.Clients." & NAME & ".Post",
                          Test_Http_Post'Access);
      end Add_Tests;

      overriding
      procedure Set_Up (T : in out Http_Test) is
      begin
         Test (T).Set_Up;
         Register;
      end Set_Up;

   end Http_Tests;

   overriding
   procedure Set_Up (T : in out Test) is
   begin
      Log.Info ("Starting test server");
      T.Server := new Test_Server;
      T.Server.Start;
   end Set_Up;

   overriding
   procedure Tear_Down (T : in out Test) is
      procedure Free is
         new Ada.Unchecked_Deallocation (Object => Test_Server'Class,
                                         Name   => Test_Server_Access);
   begin
      if T.Server /= null then
         Log.Info ("Stopping test server");
         T.Server.Stop;
         Free (T.Server);
         T.Server := null;
      end if;
   end Tear_Down;

   --  ------------------------------
   --  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) is
      L   : constant String := Ada.Strings.Unbounded.To_String (Line);
      Pos : Natural := Util.Strings.Index (L, ' ');
   begin
      if Pos > 0 and Into.Method = UNKNOWN then
         if L (L'First .. Pos - 1) = "GET" then
            Into.Method := GET;
         elsif L (L'First .. Pos - 1) = "POST" then
            Into.Method := POST;
         else
            Into.Method := UNKNOWN;
         end if;
      end if;

      Pos := Util.Strings.Index (L, ':');
      if Pos > 0 then
         if L (L'First .. Pos) = "Content-Type:" then
            Into.Content_Type
              := Ada.Strings.Unbounded.To_Unbounded_String (L (Pos + 2 .. L'Last - 2));
         elsif L (L'First .. Pos) = "Content-Length:" then
            Into.Length := Natural'Value (L (Pos + 1 .. L'Last - 2));

         end if;
      end if;
      if L'Length = 2 and then Into.Length > 0 then
         for I in 1 .. Into.Length loop
            declare
               C : Character;
            begin
               Stream.Read (C);
               Ada.Strings.Unbounded.Append (Into.Result, C);
            end;
         end loop;
         declare
            Output : Util.Streams.Texts.Print_Stream;
         begin
            Output.Initialize (Client'Unchecked_Access);
            Output.Write ("HTTP/1.1 200 Found" & ASCII.CR & ASCII.LF);
            Output.Write ("Content-Length: 4" & ASCII.CR & ASCII.LF);
            Output.Write (ASCII.CR & ASCII.LF);
            Output.Write ("OK" & ASCII.CR & ASCII.LF);
            Output.Flush;
         end;
      end if;
      Log.Info ("Received: {0}", L);
   end Process_Line;

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

   begin
      return "http://" & T.Server.Get_Host & ":" & Util.Strings.Image (T.Server.Get_Port);
   end Get_Uri;

   --  ------------------------------
   --  Test the http Get operation.
   --  ------------------------------
   procedure Test_Http_Get (T : in out Test) is
      Request : Client;
      Reply   : Response;
   begin
      Request.Get ("http://www.google.com", Reply);
      T.Assert (Reply.Get_Status = 200 or Reply.Get_Status = 302, "Get status is invalid");

      Util.Http.Tools.Save_Response (Util.Tests.Get_Test_Path ("http_get.txt"), Reply, True);

      --  Check the content.
      declare
         Content : constant String := Util.Strings.Transforms.To_Lower_Case (Reply.Get_Body);
      begin
         Util.Tests.Assert_Matches (T, ".*html.*", Content, "Invalid GET content");
      end;

      --  Check one header.
      declare
         Content : constant String := Reply.Get_Header ("Content-Type");
      begin
         T.Assert (Content'Length > 0, "Empty Content-Type header");
         Util.Tests.Assert_Matches (T, ".*text/html.*", Content, "Invalid content type");
      end;
   end Test_Http_Get;

   --  ------------------------------
   --  Test the http POST operation.
   --  ------------------------------
   procedure Test_Http_Post (T : in out Test) is
      Request : Client;
      Reply   : Response;
      Uri     : constant String := T.Get_Uri;
   begin
      Log.Info ("Post on " & Uri);

      T.Server.Method := UNKNOWN;
      Request.Post (Uri & "/post",
                    "p1=1", Reply);

      T.Assert (T.Server.Method = POST, "Invalid method received by server");
      Util.Tests.Assert_Equals (T, "application/x-www-form-urlencoded", T.Server.Content_Type,
                                "Invalid content type received by server");
      Util.Tests.Assert_Equals (T, "OK" & ASCII.CR & ASCII.LF, Reply.Get_Body, "Invalid response");
      Util.Http.Tools.Save_Response (Util.Tests.Get_Test_Path ("http_post.txt"), Reply, True);

   end Test_Http_Post;

end Util.Http.Clients.Tests;

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

with Util.Test_Caller;

with Util.Strings.Transforms;
with Util.Http.Tools;
with Util.Strings;
with Util.Log.Loggers;

package body Util.Http.Clients.Tests is

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Util.Http.Clients.Tests");

   package body Http_Tests is
      package Caller is new Util.Test_Caller (Http_Test, "Http-" & NAME);

      procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
      begin
         Caller.Add_Test (Suite, "Test Util.Http.Clients." & NAME & ".Get",
                          Test_Http_Get'Access);
         Caller.Add_Test (Suite, "Test Util.Http.Clients." & NAME & ".Post",
                          Test_Http_Post'Access);
      end Add_Tests;

      overriding
      procedure Set_Up (T : in out Http_Test) is
      begin
         Test (T).Set_Up;
         Register;
      end Set_Up;

   end Http_Tests;

   overriding
   procedure Set_Up (T : in out Test) is
   begin
      Log.Info ("Starting test server");
      T.Server := new Test_Server;
      T.Server.Start;
   end Set_Up;

   overriding
   procedure Tear_Down (T : in out Test) is
      procedure Free is
         new Ada.Unchecked_Deallocation (Object => Test_Server'Class,
                                         Name   => Test_Server_Access);
   begin
      if T.Server /= null then
         Log.Info ("Stopping test server");
         T.Server.Stop;
         Free (T.Server);
         T.Server := null;
      end if;
   end Tear_Down;

   --  ------------------------------
   --  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) is
      L   : constant String := Ada.Strings.Unbounded.To_String (Line);
      Pos : Natural := Util.Strings.Index (L, ' ');
   begin
      if Pos > 0 and Into.Method = UNKNOWN then
         if L (L'First .. Pos - 1) = "GET" then
            Into.Method := GET;
         elsif L (L'First .. Pos - 1) = "POST" then
            Into.Method := POST;
         else
            Into.Method := UNKNOWN;
         end if;
      end if;

      Pos := Util.Strings.Index (L, ':');
      if Pos > 0 then
         if L (L'First .. Pos) = "Content-Type:" then
            Into.Content_Type
              := Ada.Strings.Unbounded.To_Unbounded_String (L (Pos + 2 .. L'Last - 2));
         elsif L (L'First .. Pos) = "Content-Length:" then
            Into.Length := Natural'Value (L (Pos + 1 .. L'Last - 2));

         end if;
      end if;
      if L'Length = 2 and then Into.Length > 0 then
         for I in 1 .. Into.Length loop
            declare
               C : Character;
            begin
               Stream.Read (C);
               Ada.Strings.Unbounded.Append (Into.Result, C);
            end;
         end loop;
         declare
            Output : Util.Streams.Texts.Print_Stream;
         begin
            Output.Initialize (Client'Unchecked_Access);
            Output.Write ("HTTP/1.1 200 Found" & ASCII.CR & ASCII.LF);
            Output.Write ("Content-Length: 4" & ASCII.CR & ASCII.LF);
            Output.Write (ASCII.CR & ASCII.LF);
            Output.Write ("OK" & ASCII.CR & ASCII.LF);
            Output.Flush;
         end;
      end if;
      Log.Info ("Received: {0}", L);
   end Process_Line;

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

   begin
      return "http://" & T.Server.Get_Host & ":" & Util.Strings.Image (T.Server.Get_Port);
   end Get_Uri;

   --  ------------------------------
   --  Test the http Get operation.
   --  ------------------------------
   procedure Test_Http_Get (T : in out Test) is
      Request : Client;
      Reply   : Response;
   begin
      Request.Get ("http://www.google.com", Reply);
      T.Assert (Reply.Get_Status = 200 or Reply.Get_Status = 302,
                "Get status is invalid: " & Natural'Image (Reply.Get_Status));

      Util.Http.Tools.Save_Response (Util.Tests.Get_Test_Path ("http_get.txt"), Reply, True);

      --  Check the content.
      declare
         Content : constant String := Util.Strings.Transforms.To_Lower_Case (Reply.Get_Body);
      begin
         Util.Tests.Assert_Matches (T, ".*html.*", Content, "Invalid GET content");
      end;

      --  Check one header.
      declare
         Content : constant String := Reply.Get_Header ("Content-Type");
      begin
         T.Assert (Content'Length > 0, "Empty Content-Type header");
         Util.Tests.Assert_Matches (T, ".*text/html.*", Content, "Invalid content type");
      end;
   end Test_Http_Get;

   --  ------------------------------
   --  Test the http POST operation.
   --  ------------------------------
   procedure Test_Http_Post (T : in out Test) is
      Request : Client;
      Reply   : Response;
      Uri     : constant String := T.Get_Uri;
   begin
      Log.Info ("Post on " & Uri);

      T.Server.Method := UNKNOWN;
      Request.Post (Uri & "/post",
                    "p1=1", Reply);

      T.Assert (T.Server.Method = POST, "Invalid method received by server");
      Util.Tests.Assert_Equals (T, "application/x-www-form-urlencoded", T.Server.Content_Type,
                                "Invalid content type received by server");
      Util.Tests.Assert_Equals (T, "OK" & ASCII.CR & ASCII.LF, Reply.Get_Body, "Invalid response");
      Util.Http.Tools.Save_Response (Util.Tests.Get_Test_Path ("http_post.txt"), Reply, True);

   end Test_Http_Post;

end Util.Http.Clients.Tests;

Update the test to indicate the HTTP response status if an error occurs


-----------------------------------------------------------------------
--  mat-formats - Format various types for the console or GUI interface
--  Copyright (C) 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.Strings;
package body MAT.Formats is

   use type MAT.Types.Target_Tick_Ref;

   Hex_Prefix : Boolean := True;

   Conversion : constant String (1 .. 10) := "0123456789";

   function Location (File : in Ada.Strings.Unbounded.Unbounded_String) return String;

   function Event_Malloc (Item       : in MAT.Events.Targets.Probe_Event_Type;
                          Related    : in MAT.Events.Targets.Target_Event_Vector;
                          Start_Time : in MAT.Types.Target_Tick_Ref) return String;

   function Event_Free (Item       : in MAT.Events.Targets.Probe_Event_Type;
                        Related    : in MAT.Events.Targets.Target_Event_Vector;
                        Start_Time : in MAT.Types.Target_Tick_Ref) return String;

   --  ------------------------------
   --  Format the address into a string.
   --  ------------------------------
   function Addr (Value : in MAT.Types.Target_Addr) return String is
      Hex : constant String := MAT.Types.Hex_Image (Value);
   begin
      if Hex_Prefix then
         return "0x" & Hex;
      else
         return Hex;
      end if;
   end Addr;

   --  ------------------------------
   --  Format the size into a string.
   --  ------------------------------
   function Size (Value : in MAT.Types.Target_Size) return String is
      Result : constant String := MAT.Types.Target_Size'Image (Value);
   begin
      if Result (Result'First) = ' ' then
         return Result (Result'First + 1 .. Result'Last);
      else
         return Result;
      end if;
   end Size;

   --  ------------------------------
   --  Format the time relative to the start time.
   --  ------------------------------
   function Time (Value : in MAT.Types.Target_Tick_Ref;
                  Start : in MAT.Types.Target_Tick_Ref) return String is
      T    : constant MAT.Types.Target_Tick_Ref := Value - Start;
      Sec  : constant MAT.Types.Target_Tick_Ref := T / 1_000_000;
      Usec : constant MAT.Types.Target_Tick_Ref := T mod 1_000_000;
      Msec : Natural := Natural (Usec / 1_000);
      Frac : String (1 .. 5);
   begin
      Frac (5) := 's';
      Frac (4) := Conversion (Msec mod 10 + 1);
      Msec := Msec / 10;
      Frac (3) := Conversion (Msec mod 10 + 1);
      Msec := Msec / 10;
      Frac (2) := Conversion (Msec mod 10 + 1);
      Frac (1) := '.';
      return MAT.Types.Target_Tick_Ref'Image (Sec) & Frac;
   end Time;

   --  ------------------------------
   --  Format the duration in seconds, milliseconds or microseconds.
   --  ------------------------------
   function Duration (Value : in MAT.Types.Target_Tick_Ref) return String is

      Sec  : constant MAT.Types.Target_Tick_Ref := Value / 1_000_000;
      Usec : constant MAT.Types.Target_Tick_Ref := Value mod 1_000_000;
      Msec : constant Natural := Natural (Usec / 1_000);
      Val  : Natural;
      Frac : String (1 .. 5);
   begin
      if Sec = 0 and Msec = 0 then
         return Util.Strings.Image (Integer (Usec)) & "us";
      elsif Sec = 0 then
         Val := Natural (Usec mod 1_000);
         Frac (5) := 's';
         Frac (4) := 'm';
         Frac (3) := Conversion (Val mod 10 + 1);
         Val := Val / 10;
         Frac (3) := Conversion (Val mod 10 + 1);
         Val := Val / 10;
         Frac (2) := Conversion (Val mod 10 + 1);
         Frac (1) := '.';
         return Util.Strings.Image (Integer (Msec)) & Frac;
      else
         Val := Msec;
         Frac (4) := 's';
         Frac (3) := Conversion (Val mod 10 + 1);
         Val := Val / 10;
         Frac (3) := Conversion (Val mod 10 + 1);
         Val := Val / 10;
         Frac (2) := Conversion (Val mod 10 + 1);
         Frac (1) := '.';
         return Util.Strings.Image (Integer (Msec)) & Frac (1 .. 4);
      end if;
   end Duration;

   function Location (File : in Ada.Strings.Unbounded.Unbounded_String) return String is
      Pos : constant Natural := Ada.Strings.Unbounded.Index (File, "/", Ada.Strings.Backward);
      Len : constant Natural := Ada.Strings.Unbounded.Length (File);
   begin
      if Pos /= 0 then
         return Ada.Strings.Unbounded.Slice (File, Pos + 1, Len);
      else
         return Ada.Strings.Unbounded.To_String (File);
      end if;
   end Location;

   --  ------------------------------
   --  Format a file, line, function information into a string.
   --  ------------------------------
   function Location (File : in Ada.Strings.Unbounded.Unbounded_String;
                      Line : in Natural;
                      Func : in Ada.Strings.Unbounded.Unbounded_String) return String is
   begin
      if Ada.Strings.Unbounded.Length (File) = 0 then
         return Ada.Strings.Unbounded.To_String (Func);
      elsif Line > 0 then
         declare
            Num : constant String := Natural'Image (Line);
         begin
            return Ada.Strings.Unbounded.To_String (Func) & " ("
              & Location (File) & ":" & Num (Num'First + 1 .. Num'Last) & ")";
         end;
      else
         return Ada.Strings.Unbounded.To_String (Func) & " (" & Location (File) & ")";
      end if;
   end Location;

   --  ------------------------------
   --  Format a short description of the event.
   --  ------------------------------
   function Event (Item : in MAT.Events.Targets.Probe_Event_Type;
                   Mode : in Format_Type := NORMAL) return String is
      use type MAT.Types.Target_Addr;
   begin
      case Item.Index is
         when MAT.Events.Targets.MSG_MALLOC =>
            if Mode = BRIEF then
               return "malloc(" & Size (Item.Size) & ")";
            else
               return "malloc(" & Size (Item.Size) & ") = " & Addr (Item.Addr);
            end if;

         when MAT.Events.Targets.MSG_REALLOC =>
            if Mode = BRIEF then
               if Item.Old_Addr = 0 then
                  return "realloc(0," & Size (Item.Size) & ")";
               else
                  return "realloc(" & Addr (Item.Old_Addr) & "," & Size (Item.Size) & ")";
               end if;
            else
               if Item.Old_Addr = 0 then
                  return "realloc(0," & Size (Item.Size) & ") = "
                    & Addr (Item.Addr);
               else
                  return "realloc(" & Addr (Item.Old_Addr) & "," & Size (Item.Size) & ") = "
                    & Addr (Item.Addr);
               end if;
            end if;

         when MAT.Events.Targets.MSG_FREE =>
            return "free(" & Addr (Item.Addr) & ")";

         when MAT.Events.Targets.MSG_BEGIN =>
            return "begin";

         when MAT.Events.Targets.MSG_END =>
            return "end";

         when MAT.Events.Targets.MSG_LIBRARY =>
            return "library";

      end case;
   end Event;

   function Event_Malloc (Item       : in MAT.Events.Targets.Probe_Event_Type;
                          Related    : in MAT.Events.Targets.Target_Event_Vector;
                          Start_Time : in MAT.Types.Target_Tick_Ref) return String is
      Free_Event : MAT.Events.Targets.Probe_Event_Type;
   begin
      Free_Event := MAT.Events.Targets.Find (Related, MAT.Events.Targets.MSG_FREE);

      return Size (Item.Size) & " bytes allocated after " & Duration (Item.Time - Start_Time)
        & ", freed " & Duration (Free_Event.Time - Item.Time)
        & " after by event" & MAT.Events.Targets.Event_Id_Type'Image (Free_Event.Id)
      ;

   exception
      when MAT.Events.Targets.Not_Found =>
         return Size (Item.Size) & " bytes allocated (never freed)";

   end Event_Malloc;

   function Event_Free (Item       : in MAT.Events.Targets.Probe_Event_Type;
                        Related    : in MAT.Events.Targets.Target_Event_Vector;
                        Start_Time : in MAT.Types.Target_Tick_Ref) return String is
      Alloc_Event : MAT.Events.Targets.Probe_Event_Type;
   begin
      Alloc_Event := MAT.Events.Targets.Find (Related, MAT.Events.Targets.MSG_MALLOC);

      return Size (Alloc_Event.Size) & " bytes freed after " & Duration (Item.Time - Start_Time)
        & ", alloc'ed for " & Duration (Item.Time - Alloc_Event.Time)
        & " by event" & MAT.Events.Targets.Event_Id_Type'Image (Alloc_Event.Id);

   exception
      when MAT.Events.Targets.Not_Found =>
         return Size (Item.Size) & " bytes freed";

   end Event_Free;

   --  ------------------------------
   --  Format a short description of the event.
   --  ------------------------------
   function Event (Item       : in MAT.Events.Targets.Probe_Event_Type;
                   Related    : in MAT.Events.Targets.Target_Event_Vector;
                   Start_Time : in MAT.Types.Target_Tick_Ref) return String is
   begin
      case Item.Index is
         when MAT.Events.Targets.MSG_MALLOC =>
            return Event_Malloc (Item, Related, Start_Time);

         when MAT.Events.Targets.MSG_REALLOC =>
            return Size (Item.Size) & " bytes reallocated";

         when MAT.Events.Targets.MSG_FREE =>
            return Event_Free (Item, Related, Start_Time);

         when MAT.Events.Targets.MSG_BEGIN =>
            return "Begin event";

         when MAT.Events.Targets.MSG_END =>
            return "End event";

         when MAT.Events.Targets.MSG_LIBRARY =>
            return "Library information event";

      end case;
   end Event;

end MAT.Formats;

-----------------------------------------------------------------------
--  mat-formats - Format various types for the console or GUI interface
--  Copyright (C) 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.Strings;
package body MAT.Formats is

   use type MAT.Types.Target_Tick_Ref;

   Hex_Prefix : Boolean := True;

   Conversion : constant String (1 .. 10) := "0123456789";

   function Location (File : in Ada.Strings.Unbounded.Unbounded_String) return String;

   function Event_Malloc (Item       : in MAT.Events.Targets.Probe_Event_Type;
                          Related    : in MAT.Events.Targets.Target_Event_Vector;
                          Start_Time : in MAT.Types.Target_Tick_Ref) return String;

   function Event_Free (Item       : in MAT.Events.Targets.Probe_Event_Type;
                        Related    : in MAT.Events.Targets.Target_Event_Vector;
                        Start_Time : in MAT.Types.Target_Tick_Ref) return String;

   --  ------------------------------
   --  Format the address into a string.
   --  ------------------------------
   function Addr (Value : in MAT.Types.Target_Addr) return String is
      Hex : constant String := MAT.Types.Hex_Image (Value);
   begin
      if Hex_Prefix then
         return "0x" & Hex;
      else
         return Hex;
      end if;
   end Addr;

   --  ------------------------------
   --  Format the size into a string.
   --  ------------------------------
   function Size (Value : in MAT.Types.Target_Size) return String is
      Result : constant String := MAT.Types.Target_Size'Image (Value);
   begin
      if Result (Result'First) = ' ' then
         return Result (Result'First + 1 .. Result'Last);
      else
         return Result;
      end if;
   end Size;

   --  ------------------------------
   --  Format the time relative to the start time.
   --  ------------------------------
   function Time (Value : in MAT.Types.Target_Tick_Ref;
                  Start : in MAT.Types.Target_Tick_Ref) return String is
      T    : constant MAT.Types.Target_Tick_Ref := Value - Start;
      Sec  : constant MAT.Types.Target_Tick_Ref := T / 1_000_000;
      Usec : constant MAT.Types.Target_Tick_Ref := T mod 1_000_000;
      Msec : Natural := Natural (Usec / 1_000);
      Frac : String (1 .. 5);
   begin
      Frac (5) := 's';
      Frac (4) := Conversion (Msec mod 10 + 1);
      Msec := Msec / 10;
      Frac (3) := Conversion (Msec mod 10 + 1);
      Msec := Msec / 10;
      Frac (2) := Conversion (Msec mod 10 + 1);
      Frac (1) := '.';
      return MAT.Types.Target_Tick_Ref'Image (Sec) & Frac;
   end Time;

   --  ------------------------------
   --  Format the duration in seconds, milliseconds or microseconds.
   --  ------------------------------
   function Duration (Value : in MAT.Types.Target_Tick_Ref) return String is

      Sec  : constant MAT.Types.Target_Tick_Ref := Value / 1_000_000;
      Usec : constant MAT.Types.Target_Tick_Ref := Value mod 1_000_000;
      Msec : constant Natural := Natural (Usec / 1_000);
      Val  : Natural;
      Frac : String (1 .. 5);
   begin
      if Sec = 0 and Msec = 0 then
         return Util.Strings.Image (Integer (Usec)) & "us";
      elsif Sec = 0 then
         Val := Natural (Usec mod 1_000);
         Frac (5) := 's';
         Frac (4) := 'm';
         Frac (3) := Conversion (Val mod 10 + 1);
         Val := Val / 10;
         Frac (3) := Conversion (Val mod 10 + 1);
         Val := Val / 10;
         Frac (2) := Conversion (Val mod 10 + 1);
         Frac (1) := '.';
         return Util.Strings.Image (Integer (Msec)) & Frac;
      else
         Val := Msec;
         Frac (4) := 's';
         Frac (3) := Conversion (Val mod 10 + 1);
         Val := Val / 10;
         Frac (3) := Conversion (Val mod 10 + 1);
         Val := Val / 10;
         Frac (2) := Conversion (Val mod 10 + 1);
         Frac (1) := '.';
         return Util.Strings.Image (Integer (Sec)) & Frac (1 .. 4);
      end if;
   end Duration;

   function Location (File : in Ada.Strings.Unbounded.Unbounded_String) return String is
      Pos : constant Natural := Ada.Strings.Unbounded.Index (File, "/", Ada.Strings.Backward);
      Len : constant Natural := Ada.Strings.Unbounded.Length (File);
   begin
      if Pos /= 0 then
         return Ada.Strings.Unbounded.Slice (File, Pos + 1, Len);
      else
         return Ada.Strings.Unbounded.To_String (File);
      end if;
   end Location;

   --  ------------------------------
   --  Format a file, line, function information into a string.
   --  ------------------------------
   function Location (File : in Ada.Strings.Unbounded.Unbounded_String;
                      Line : in Natural;
                      Func : in Ada.Strings.Unbounded.Unbounded_String) return String is
   begin
      if Ada.Strings.Unbounded.Length (File) = 0 then
         return Ada.Strings.Unbounded.To_String (Func);
      elsif Line > 0 then
         declare
            Num : constant String := Natural'Image (Line);
         begin
            return Ada.Strings.Unbounded.To_String (Func) & " ("
              & Location (File) & ":" & Num (Num'First + 1 .. Num'Last) & ")";
         end;
      else
         return Ada.Strings.Unbounded.To_String (Func) & " (" & Location (File) & ")";
      end if;
   end Location;

   --  ------------------------------
   --  Format a short description of the event.
   --  ------------------------------
   function Event (Item : in MAT.Events.Targets.Probe_Event_Type;
                   Mode : in Format_Type := NORMAL) return String is
      use type MAT.Types.Target_Addr;
   begin
      case Item.Index is
         when MAT.Events.Targets.MSG_MALLOC =>
            if Mode = BRIEF then
               return "malloc(" & Size (Item.Size) & ")";
            else
               return "malloc(" & Size (Item.Size) & ") = " & Addr (Item.Addr);
            end if;

         when MAT.Events.Targets.MSG_REALLOC =>
            if Mode = BRIEF then
               if Item.Old_Addr = 0 then
                  return "realloc(0," & Size (Item.Size) & ")";
               else
                  return "realloc(" & Addr (Item.Old_Addr) & "," & Size (Item.Size) & ")";
               end if;
            else
               if Item.Old_Addr = 0 then
                  return "realloc(0," & Size (Item.Size) & ") = "
                    & Addr (Item.Addr);
               else
                  return "realloc(" & Addr (Item.Old_Addr) & "," & Size (Item.Size) & ") = "
                    & Addr (Item.Addr);
               end if;
            end if;

         when MAT.Events.Targets.MSG_FREE =>
            return "free(" & Addr (Item.Addr) & ")";

         when MAT.Events.Targets.MSG_BEGIN =>
            return "begin";

         when MAT.Events.Targets.MSG_END =>
            return "end";

         when MAT.Events.Targets.MSG_LIBRARY =>
            return "library";

      end case;
   end Event;

   function Event_Malloc (Item       : in MAT.Events.Targets.Probe_Event_Type;
                          Related    : in MAT.Events.Targets.Target_Event_Vector;
                          Start_Time : in MAT.Types.Target_Tick_Ref) return String is
      Free_Event : MAT.Events.Targets.Probe_Event_Type;
   begin
      Free_Event := MAT.Events.Targets.Find (Related, MAT.Events.Targets.MSG_FREE);

      return Size (Item.Size) & " bytes allocated after " & Duration (Item.Time - Start_Time)
        & ", freed " & Duration (Free_Event.Time - Item.Time)
        & " after by event" & MAT.Events.Targets.Event_Id_Type'Image (Free_Event.Id)
      ;

   exception
      when MAT.Events.Targets.Not_Found =>
         return Size (Item.Size) & " bytes allocated (never freed)";

   end Event_Malloc;

   function Event_Free (Item       : in MAT.Events.Targets.Probe_Event_Type;
                        Related    : in MAT.Events.Targets.Target_Event_Vector;
                        Start_Time : in MAT.Types.Target_Tick_Ref) return String is
      Alloc_Event : MAT.Events.Targets.Probe_Event_Type;
   begin
      Alloc_Event := MAT.Events.Targets.Find (Related, MAT.Events.Targets.MSG_MALLOC);

      return Size (Alloc_Event.Size) & " bytes freed after " & Duration (Item.Time - Start_Time)
        & ", alloc'ed for " & Duration (Item.Time - Alloc_Event.Time)
        & " by event" & MAT.Events.Targets.Event_Id_Type'Image (Alloc_Event.Id);

   exception
      when MAT.Events.Targets.Not_Found =>
         return Size (Item.Size) & " bytes freed";

   end Event_Free;

   --  ------------------------------
   --  Format a short description of the event.
   --  ------------------------------
   function Event (Item       : in MAT.Events.Targets.Probe_Event_Type;
                   Related    : in MAT.Events.Targets.Target_Event_Vector;
                   Start_Time : in MAT.Types.Target_Tick_Ref) return String is
   begin
      case Item.Index is
         when MAT.Events.Targets.MSG_MALLOC =>
            return Event_Malloc (Item, Related, Start_Time);

         when MAT.Events.Targets.MSG_REALLOC =>
            return Size (Item.Size) & " bytes reallocated";

         when MAT.Events.Targets.MSG_FREE =>
            return Event_Free (Item, Related, Start_Time);

         when MAT.Events.Targets.MSG_BEGIN =>
            return "Begin event";

         when MAT.Events.Targets.MSG_END =>
            return "End event";

         when MAT.Events.Targets.MSG_LIBRARY =>
            return "Library information event";

      end case;
   end Event;

end MAT.Formats;

Fix formatting of time with seconds > 0

Fix formatting of time with seconds > 0


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

with Util.Log.Loggers;

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

   use Ada.Strings.Unbounded;

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Gen.Model.Mappings");

   Types : Mapping_Maps.Map;

   Mapping_Name : Unbounded_String;

   --  ------------------------------
   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   --  ------------------------------
   overriding
   function Get_Value (From : in Mapping_Definition;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "name" then
         return Util.Beans.Objects.To_Object (From.Target);
      elsif Name = "isBoolean" then
         return Util.Beans.Objects.To_Object (From.Kind = T_BOOLEAN);
      elsif Name = "isInteger" then
         return Util.Beans.Objects.To_Object (From.Kind = T_INTEGER);
      elsif Name = "isString" then
         return Util.Beans.Objects.To_Object (From.Kind = T_STRING);
      elsif Name = "isIdentifier" then
         return Util.Beans.Objects.To_Object (From.Kind = T_IDENTIFIER);
      elsif Name = "isDate" then
         return Util.Beans.Objects.To_Object (From.Kind = T_DATE);
      elsif Name = "isBlob" then
         return Util.Beans.Objects.To_Object (From.Kind = T_BLOB);
      elsif Name = "isEnum" then
         return Util.Beans.Objects.To_Object (From.Kind = T_ENUM);
      elsif Name = "isPrimitiveType" then
         return Util.Beans.Objects.To_Object (From.Kind /= T_TABLE and From.Kind /= T_BLOB);
      else
         return Definition (From).Get_Value (Name);
      end if;
   end Get_Value;

   --  ------------------------------
   --  Find the mapping for the given type name.
   --  ------------------------------
   function Find_Type (Name       : in Ada.Strings.Unbounded.Unbounded_String;
                       Allow_Null : in Boolean)
                       return Mapping_Definition_Access is
      Pos : constant Mapping_Maps.Cursor := Types.Find (Mapping_Name & Name);
   begin
      if not Mapping_Maps.Has_Element (Pos) then
         Log.Info ("Type '{0}' not found in mapping table '{1}'",
                   To_String (Name), To_String (Mapping_Name));
         return null;
      elsif Allow_Null then
         if Mapping_Maps.Element (Pos).Allow_Null = null then
            Log.Info ("Type '{0}' does not allow a null value in mapping table '{1}'",
                       To_String (Name), To_String (Mapping_Name));
            return Mapping_Maps.Element (Pos);
         end if;
         return Mapping_Maps.Element (Pos).Allow_Null;
      else
         return Mapping_Maps.Element (Pos);
      end if;
   end Find_Type;

   procedure Register_Type (Name    : in String;
                            Mapping : in Mapping_Definition_Access;
                            Kind    : in Basic_Type) is
      N    : constant Unbounded_String := Mapping_Name & To_Unbounded_String (Name);
      Pos  : constant Mapping_Maps.Cursor := Types.Find (N);
   begin
      Log.Debug ("Register type '{0}'", Name);

      if not Mapping_Maps.Has_Element (Pos) then
         Mapping.Kind := Kind;
         Types.Insert (N, Mapping);
      end if;
   end Register_Type;

   --  ------------------------------
   --  Register a type mapping From that is mapped to Target.
   --  ------------------------------
   procedure Register_Type (Target     : in String;
                            From       : in String;
                            Kind       : in Basic_Type;
                            Allow_Null : in Boolean) is
      Name    : constant Unbounded_String := Mapping_Name & To_Unbounded_String (From);
      Pos     : constant Mapping_Maps.Cursor := Types.Find (Name);
      Mapping : Mapping_Definition_Access;
      Found   : Boolean;
   begin
      Log.Debug ("Register type '{0}' mapped to '{1}' type {2}",
                 From, Target, Basic_Type'Image (Kind));

      Found := Mapping_Maps.Has_Element (Pos);
      if Found then
         Mapping := Mapping_Maps.Element (Pos);
      else
         Mapping := new Mapping_Definition;
         Mapping.Set_Name (From);
         Types.Insert (Name, Mapping);
      end if;
      if Allow_Null then
         Mapping.Allow_Null := new Mapping_Definition;
         Mapping.Allow_Null.Target := To_Unbounded_String (Target);
         Mapping.Allow_Null.Kind := Kind;
         Mapping.Allow_Null.Nullable := True;
         if not Found then
            Mapping.Target := To_Unbounded_String (Target);
            Mapping.Kind   := Kind;
         end if;
      else
         Mapping.Target := To_Unbounded_String (Target);
         Mapping.Kind   := Kind;
      end if;
   end Register_Type;

   --  ------------------------------
   --  Setup the type mapping for the language identified by the given name.
   --  ------------------------------
   procedure Set_Mapping_Name (Name : in String) is
   begin
      Log.Info ("Using type mapping {0}", Name);

      Mapping_Name := To_Unbounded_String (Name & ".");
   end Set_Mapping_Name;

end Gen.Model.Mappings;

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

with Util.Log.Loggers;

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

   use Ada.Strings.Unbounded;

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Gen.Model.Mappings");

   Types : Mapping_Maps.Map;

   Mapping_Name : Unbounded_String;

   --  ------------------------------
   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   --  ------------------------------
   overriding
   function Get_Value (From : in Mapping_Definition;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "name" then
         return Util.Beans.Objects.To_Object (From.Target);
      elsif Name = "isBoolean" then
         return Util.Beans.Objects.To_Object (From.Kind = T_BOOLEAN);
      elsif Name = "isInteger" then
         return Util.Beans.Objects.To_Object (From.Kind = T_INTEGER);
      elsif Name = "isString" then
         return Util.Beans.Objects.To_Object (From.Kind = T_STRING);
      elsif Name = "isIdentifier" then
         return Util.Beans.Objects.To_Object (From.Kind = T_IDENTIFIER);
      elsif Name = "isDate" then
         return Util.Beans.Objects.To_Object (From.Kind = T_DATE);
      elsif Name = "isBlob" then
         return Util.Beans.Objects.To_Object (From.Kind = T_BLOB);
      elsif Name = "isEnum" then
         return Util.Beans.Objects.To_Object (From.Kind = T_ENUM);
      elsif Name = "isPrimitiveType" then
         return Util.Beans.Objects.To_Object (From.Kind /= T_TABLE and From.Kind /= T_BLOB);
      else
         return Definition (From).Get_Value (Name);
      end if;
   end Get_Value;

   --  ------------------------------
   --  Get the type name.
   --  ------------------------------
   function Get_Type_Name (From : Mapping_Definition) return String is
   begin
      case From.Kind is
         when T_BOOLEAN =>
            return "boolean";

         when T_INTEGER =>
            return "integer";

         when T_DATE =>
            return "date";

         when T_IDENTIFIER =>
            return "identifier";

         when T_STRING =>
            return "string";

         when T_ENUM =>
            return From.Get_Name;

         when others =>
            return From.Get_Name;

      end case;
   end Get_Type_Name;

   --  ------------------------------
   --  Find the mapping for the given type name.
   --  ------------------------------
   function Find_Type (Name       : in Ada.Strings.Unbounded.Unbounded_String;
                       Allow_Null : in Boolean)
                       return Mapping_Definition_Access is
      Pos : constant Mapping_Maps.Cursor := Types.Find (Mapping_Name & Name);
   begin
      if not Mapping_Maps.Has_Element (Pos) then
         Log.Info ("Type '{0}' not found in mapping table '{1}'",
                   To_String (Name), To_String (Mapping_Name));
         return null;
      elsif Allow_Null then
         if Mapping_Maps.Element (Pos).Allow_Null = null then
            Log.Info ("Type '{0}' does not allow a null value in mapping table '{1}'",
                       To_String (Name), To_String (Mapping_Name));
            return Mapping_Maps.Element (Pos);
         end if;
         return Mapping_Maps.Element (Pos).Allow_Null;
      else
         return Mapping_Maps.Element (Pos);
      end if;
   end Find_Type;

   procedure Register_Type (Name    : in String;
                            Mapping : in Mapping_Definition_Access;
                            Kind    : in Basic_Type) is
      N    : constant Unbounded_String := Mapping_Name & To_Unbounded_String (Name);
      Pos  : constant Mapping_Maps.Cursor := Types.Find (N);
   begin
      Log.Debug ("Register type '{0}'", Name);

      if not Mapping_Maps.Has_Element (Pos) then
         Mapping.Kind := Kind;
         Types.Insert (N, Mapping);
      end if;
   end Register_Type;

   --  ------------------------------
   --  Register a type mapping From that is mapped to Target.
   --  ------------------------------
   procedure Register_Type (Target     : in String;
                            From       : in String;
                            Kind       : in Basic_Type;
                            Allow_Null : in Boolean) is
      Name    : constant Unbounded_String := Mapping_Name & To_Unbounded_String (From);
      Pos     : constant Mapping_Maps.Cursor := Types.Find (Name);
      Mapping : Mapping_Definition_Access;
      Found   : Boolean;
   begin
      Log.Debug ("Register type '{0}' mapped to '{1}' type {2}",
                 From, Target, Basic_Type'Image (Kind));

      Found := Mapping_Maps.Has_Element (Pos);
      if Found then
         Mapping := Mapping_Maps.Element (Pos);
      else
         Mapping := new Mapping_Definition;
         Mapping.Set_Name (From);
         Types.Insert (Name, Mapping);
      end if;
      if Allow_Null then
         Mapping.Allow_Null := new Mapping_Definition;
         Mapping.Allow_Null.Target := To_Unbounded_String (Target);
         Mapping.Allow_Null.Kind := Kind;
         Mapping.Allow_Null.Nullable := True;
         if not Found then
            Mapping.Target := To_Unbounded_String (Target);
            Mapping.Kind   := Kind;
         end if;
      else
         Mapping.Target := To_Unbounded_String (Target);
         Mapping.Kind   := Kind;
      end if;
   end Register_Type;

   --  ------------------------------
   --  Setup the type mapping for the language identified by the given name.
   --  ------------------------------
   procedure Set_Mapping_Name (Name : in String) is
   begin
      Log.Info ("Using type mapping {0}", Name);

      Mapping_Name := To_Unbounded_String (Name & ".");
   end Set_Mapping_Name;

end Gen.Model.Mappings;

Implement Get_Type_Name function

Implement Get_Type_Name function