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

--  This file provides declarations for devices on the STM32F4 Discovery kits
--  manufactured by ST Microelectronics.

with STM32.Device;  use STM32.Device;

with STM32.GPIO;    use STM32.GPIO;
with STM32.I2C;     use STM32.I2C;

with MPU9250;       use MPU9250;
with AK8963;        use AK8963;

package STM32.Board is
   pragma Elaborate_Body;

   subtype User_LED is GPIO_Point;

   LED_Blue_L  : User_LED renames PD2;

   LED_Green_L : User_LED renames PC1;
   LED_Green_R : User_LED renames PC2;
   LED_Red_L   : User_LED renames PC0;
   LED_Red_R   : User_LED renames PC3;

   RG_LEDs  : GPIO_Points :=
                LED_Green_L & LED_Green_R & LED_Red_L & LED_Red_R;
   All_LEDs : GPIO_Points :=
                RG_LEDs & LED_Blue_L;
   LCH_LED  : GPIO_Point renames LED_Blue_L;

   procedure Initialize_LEDs;
   --  MUST be called prior to any use of the LEDs

   procedure Turn_On (This : in out User_LED);
   procedure Turn_Off (This : in out User_LED);
   function Is_On (This : User_LED) return Boolean;

   procedure All_LEDs_Off with Inline;
   procedure All_LEDs_On  with Inline;
   procedure Toggle_LED (This : in out User_LED)
     renames STM32.GPIO.Toggle;
   procedure Toggle_LEDs (These : in out GPIO_Points)
     renames STM32.GPIO.Toggle;

   ---------
   -- I2C --
   ---------

   procedure Initialize_I2C_GPIO (Port : in out I2C_Port)
     with
     --  I2C_2 is not accessible on this board
     Pre => As_Port_Id (Port) = I2C_Id_1
            or else As_Port_Id (Port) = I2C_Id_3;

   procedure Configure_I2C (Port : in out I2C_Port);

   MPU_I2C_Port : I2C_Port renames I2C_3;
   EXT_I2C_Port : I2C_Port renames I2C_1;

   ---------
   -- MPU --
   ---------

   MPU_Device   : MPU9250.MPU9250_Device (MPU_I2C_Port'Access, High);
   MAG_Device   : AK8963_Device (MPU_I2C_Port'Access, Add_00);

end STM32.Board;

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

--  This file provides declarations for devices on the STM32F4 Discovery kits
--  manufactured by ST Microelectronics.

with STM32.Device;  use STM32.Device;

with STM32.GPIO;    use STM32.GPIO;
with STM32.I2C;     use STM32.I2C;
with STM32.SPI;     use STM32.SPI;
with STM32.Timers;  use STM32.Timers;
with STM32.USARTs;  use STM32.USARTs;

with MPU9250;       use MPU9250;
with AK8963;        use AK8963;

package STM32.Board is
   pragma Elaborate_Body;

   subtype User_LED is GPIO_Point;

   LED_Blue_L  : User_LED renames PD2;

   LED_Green_L : User_LED renames PC1;
   LED_Green_R : User_LED renames PC2;
   LED_Red_L   : User_LED renames PC0;
   LED_Red_R   : User_LED renames PC3;

   RG_LEDs  : GPIO_Points :=
                LED_Green_L & LED_Green_R & LED_Red_L & LED_Red_R;
   All_LEDs : GPIO_Points :=
                RG_LEDs & LED_Blue_L;
   LCH_LED  : GPIO_Point renames LED_Blue_L;

   procedure Initialize_LEDs;
   --  MUST be called prior to any use of the LEDs

   procedure Turn_On (This : in out User_LED);
   procedure Turn_Off (This : in out User_LED);
   function Is_On (This : User_LED) return Boolean;

   procedure All_LEDs_Off with Inline;
   procedure All_LEDs_On  with Inline;
   procedure Toggle_LED (This : in out User_LED)
     renames STM32.GPIO.Toggle;
   procedure Toggle_LEDs (These : in out GPIO_Points)
     renames STM32.GPIO.Toggle;

   ---------
   -- PWM --
   ---------

   MOTOR_123_Timer : Timer renames Timer_2;
   MOTOR_4_Timer   : Timer renames Timer_4;
   MOTOR_1         : GPIO_Point renames PA1;
   MOTOR_1_AF      : GPIO_Alternate_Function renames GPIO_AF_TIM2;
   MOTOR_1_Channel : Timer_Channel renames Channel_2;
   MOTOR_2         : GPIO_Point renames PB11;
   MOTOR_2_AF      : GPIO_Alternate_Function renames GPIO_AF_TIM2;
   MOTOR_2_Channel : Timer_Channel renames Channel_4;
   MOTOR_3         : GPIO_Point renames PA15;
   MOTOR_3_AF      : GPIO_Alternate_Function renames GPIO_AF_TIM2;
   MOTOR_3_Channel : Timer_Channel renames Channel_1;
   MOTOR_4         : GPIO_Point renames PB9;
   MOTOR_4_AF      : GPIO_Alternate_Function renames GPIO_AF_TIM4;
   MOTOR_4_Channel : Timer_Channel renames Channel_4;

   ---------
   -- I2C --
   ---------

   procedure Initialize_I2C_GPIO (Port : in out I2C_Port)
     with
     --  I2C_2 is not accessible on this board
     Pre => As_Port_Id (Port) = I2C_Id_1
            or else As_Port_Id (Port) = I2C_Id_3;

   procedure Configure_I2C (Port : in out I2C_Port);

   I2C_MPU_Port : I2C_Port renames I2C_3;
   I2C_MPU_SCL  : GPIO_Point renames PA8;
   I2C_MPU_SDA  : GPIO_Point renames PC9;

   I2C_EXT_Port : I2C_Port renames I2C_1;
   I2C_EXT_SCL  : GPIO_Point renames PB6;
   I2C_EXT_SDA  : GPIO_Point renames PB7;

   ---------
   -- SPI --
   ---------

   EXT_SPI  : SPI_Port renames SPI_1;
   EXT_SCK  : GPIO_Point renames PA5;
   EXT_MISO : GPIO_Point renames PA6;
   EXT_MOSI : GPIO_Point renames PA7;
   EXT_CS0  : GPIO_Point renames PC12;
   EXT_CS1  : GPIO_Point renames PB4;
   EXT_CS2  : GPIO_Point renames PB5;
   EXT_CS3  : GPIO_Point renames PB8;

   ---------
   -- USB --
   ---------

   USB_ID : GPIO_Point renames PA10;
   USB_DM : GPIO_Point renames PA11;
   USB_DP : GPIO_Point renames PA12;

   --------------------------
   -- External connections --
   --------------------------

   EXT_USART1    : USART renames USART_3;
   EXT_USART1_AF : GPIO_Alternate_Function renames GPIO_AF_USART3;
   EXT_USART1_TX : GPIO_Point renames PC10;
   EXT_USART1_RX : GPIO_Point renames PC11;
   EXT_USART2    : USART renames USART_2;
   EXT_USART2_AF : GPIO_Alternate_Function renames GPIO_AF_USART2;
   EXT_USART2_TX : GPIO_Point renames PA2;
   EXT_USART2_RX : GPIO_Point renames PA3;

   -----------
   -- Radio --
   -----------

   NRF_USART     : USART renames USART_6;
   NRF_USART_AF  : GPIO_Alternate_Function renames GPIO_AF_USART6;
   NRF_RX        : GPIO_Point renames PC6;
   NRF_TX        : GPIO_Point renames PC7;
   NRF_SWCLK     : GPIO_Point renames PB13;
   NRF_SWIO      : GPIO_Point renames PB15;
   NRF_FLOW_CTRL : GPIO_Point renames PA4;

   ---------
   -- MPU --
   ---------

   MPU_Device   : MPU9250.MPU9250_Device (I2C_MPU_Port'Access, High);
   MPU_INT      : GPIO_Point renames PC13;
   MPU_FSYNC    : GPIO_Point renames PC14;

   MAG_Device   : AK8963_Device (I2C_MPU_Port'Access, Add_00);

end STM32.Board;

Add the Crazyflie board components to its stm32-board spec.


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

with ASF.Requests;
with ASF.Contexts.Writer;
package body ASF.Components.Widgets.Likes is

   FB_LAYOUT_ATTR      : aliased constant String := "data-layout";
   FB_SHOW_FACES_ATTR  : aliased constant String := "data-show-faces";
   FB_WIDTH_ATTR       : aliased constant String := "data-width";
   FB_ACTION_ATTR      : aliased constant String := "data-action";
   FB_FONT_ATTR        : aliased constant String := "data-font";
   FB_COlORSCHEME_ATTR : aliased constant String := "data-colorscheme";
   FB_REF_ATTR         : aliased constant String := "data-ref";
   FB_KIDS_ATTR        : aliased constant String := "data-kid_directed_site";
   FB_SEND_ATTR        : aliased constant String := "data-send";

   TW_VIA_ATTR         : aliased constant String := "data-via";
   TW_COUNT_ATTR       : aliased constant String := "data-count";
   TW_SIZE_ATTR        : aliased constant String := "data-size";

   G_ANNOTATION_ATTR   : aliased constant String := "data-annotation";
   G_WIDTH_ATTR        : aliased constant String := "data-width";

   FACEBOOK_ATTRIBUTE_NAMES  : Util.Strings.String_Set.Set;
   FACEBOOK_SCRIPT_ATTRIBUTE : constant String := "asf.widgets.facebook.script";

   GOOGLE_ATTRIBUTE_NAMES    : Util.Strings.String_Set.Set;
   GOOGLE_SCRIPT_ATTRIBUTE   : constant String := "asf.widgets.google.script";

   TWITTER_ATTRIBUTE_NAMES    : Util.Strings.String_Set.Set;
   TWITTER_SCRIPT_ATTRIBUTE   : constant String := "asf.widgets.twitter.script";

   type Like_Generator_Binding is record
      Name      : Util.Strings.Name_Access;
      Generator : Like_Generator_Access;
   end record;

   type Like_Generator_Array is array (1 .. MAX_LIKE_GENERATOR) of Like_Generator_Binding;

   FB_NAME      : aliased constant String := "facebook";
   FB_GENERATOR : aliased Facebook_Like_Generator;

   G_NAME       : aliased constant String := "google+";
   G_GENERATOR  : aliased Google_Like_Generator;

   TWITTER_NAME       : aliased constant String := "twitter";
   TWITTER_GENERATOR  : aliased Twitter_Like_Generator;

   Generators : Like_Generator_Array := (1 => (FB_NAME'Access, FB_GENERATOR'Access),
                                         2 => (G_NAME'Access, G_GENERATOR'Access),
                                         3 => (TWITTER_NAME'Access, TWITTER_GENERATOR'Access),
                                         others => (null, null));

   --  ------------------------------
   --  Render the facebook like button according to the component attributes.
   --  ------------------------------
   overriding
   procedure Render_Like (Generator : in Facebook_Like_Generator;
                          UI        : in UILike'Class;
                          Href      : in String;
                          Context   : in out ASF.Contexts.Faces.Faces_Context'Class) is
      Writer  : constant Contexts.Writer.Response_Writer_Access := Context.Get_Response_Writer;
      Request : constant ASF.Requests.Request_Access := Context.Get_Request;
   begin
      if not Context.Is_Ajax_Request and then
        Util.Beans.Objects.Is_Null (Request.Get_Attribute (FACEBOOK_SCRIPT_ATTRIBUTE)) then

         Request.Set_Attribute (FACEBOOK_SCRIPT_ATTRIBUTE, Util.Beans.Objects.To_Object (True));
         Writer.Queue_Script ("(function(d, s, id) { var js, fjs = d.getElementsByTagName(s)[0];"
                              & "if (d.getElementById(id)) return;"
                              & "js = d.createElement(s); js.id = id;"
                              & "js.src = ""//connect.facebook.net/");
         Writer.Queue_Script (Util.Locales.To_String (Context.Get_Locale));
         Writer.Queue_Script ("/all.js#xfbml=1&;appId=116337738505130");
         Writer.Queue_Script (Generator.App_Id);
         Writer.Queue_Script (""";fjs.parentNode.insertBefore(js, fjs);"
                              & "}(document, 'script', 'facebook-jssdk'));");
         Writer.Start_Element ("div");
         Writer.Write_Attribute ("id", "fb-root");
         Writer.End_Element ("div");
      end if;
      Writer.Start_Element ("div");
      Writer.Write_Attribute ("class", "fb-like");
      Writer.Write_Attribute ("data-href", Href);
      UI.Render_Attributes (Context, FACEBOOK_ATTRIBUTE_NAMES, Writer);
      Writer.End_Element ("div");
   end Render_Like;

   --  ------------------------------
   --  Google like generator
   --  ------------------------------
   overriding
   procedure Render_Like (Generator : in Google_Like_Generator;
                          UI        : in UILike'Class;
                          Href      : in String;
                          Context   : in out ASF.Contexts.Faces.Faces_Context'Class) is
      pragma Unreferenced (Generator);

      Writer  : constant Contexts.Writer.Response_Writer_Access := Context.Get_Response_Writer;
      Request : constant ASF.Requests.Request_Access := Context.Get_Request;
   begin
      if not Context.Is_Ajax_Request and then
        Util.Beans.Objects.Is_Null (Request.Get_Attribute (GOOGLE_SCRIPT_ATTRIBUTE)) then

         Request.Set_Attribute (GOOGLE_SCRIPT_ATTRIBUTE, Util.Beans.Objects.To_Object (True));
         Writer.Queue_Include_Script ("https://apis.google.com/js/plusone.js");
      end if;
      Writer.Start_Element ("div");
      Writer.Write_Attribute ("class", "g-plusone");
      Writer.Write_Attribute ("data-href", Href);
      UI.Render_Attributes (Context, GOOGLE_ATTRIBUTE_NAMES, Writer);
      Writer.End_Element ("div");
   end Render_Like;

   --  ------------------------------
   --  Tweeter like generator
   --  ------------------------------
   overriding
   procedure Render_Like (Generator : in Twitter_Like_Generator;
                          UI        : in UILike'Class;
                          Href      : in String;
                          Context   : in out ASF.Contexts.Faces.Faces_Context'Class) is
      pragma Unreferenced (Generator);

      Writer  : constant Contexts.Writer.Response_Writer_Access := Context.Get_Response_Writer;
      Request : constant ASF.Requests.Request_Access := Context.Get_Request;
      Lang    : constant String := Util.Locales.Get_ISO3_Language (Context.Get_Locale);
   begin
      if not Context.Is_Ajax_Request and then
        Util.Beans.Objects.Is_Null (Request.Get_Attribute (TWITTER_SCRIPT_ATTRIBUTE)) then

         Request.Set_Attribute (TWITTER_SCRIPT_ATTRIBUTE, Util.Beans.Objects.To_Object (True));
         Writer.Queue_Script ("!function(d,s,id){var js,fjs=d.getElementsByTagName(s)[0],"
                              & "p=/^http:/.test(d.location)?'http':'https';"
                              & "if(!d.getElementById(id)){js=d.createElement(s);js.id=id;"
                              & "js.src=p+'://platform.twitter.com/widgets.js';"
                              & "fjs.parentNode.insertBefore(js,fjs);}}"
                              & "(document, 'script', 'twitter-wjs');");
      end if;
      Writer.Start_Element ("a");
      Writer.Write_Attribute ("href", "https://twitter.com/share");
      Writer.Write_Attribute ("class", "twitter-share-button");
      Writer.Write_Attribute ("data-url", Href);
      Writer.Write_Attribute ("data-lang", Lang);
      UI.Render_Attributes (Context, TWITTER_ATTRIBUTE_NAMES, Writer);
      Writer.Write_Text ("Tweet");
      Writer.End_Element ("a");
   end Render_Like;

   --  ------------------------------
   --  Get the link to submit in the like action.
   --  ------------------------------
   function Get_Link (UI      : in UILike;
                      Context : in ASF.Contexts.Faces.Faces_Context'Class) return String is
      Href : constant String := UI.Get_Attribute ("href", Context, "");
   begin
      if Href'Length > 0 then
         return Href;
      else
         return Context.Get_Request.Get_Request_URI;
      end if;
   end Get_Link;

   --  ------------------------------
   --  Render an image with the source link created from an email address to the Gravatars service.
   --  ------------------------------
   overriding
   procedure Encode_Begin (UI      : in UILike;
                           Context : in out ASF.Contexts.Faces.Faces_Context'Class) is

   begin
      if UI.Is_Rendered (Context) then
         declare
            Kind : constant String := UI.Get_Attribute ("type", Context, "");
            Href : constant String := UILike'Class (UI).Get_Link (Context);

            procedure Render (Name : in String; Done : out Boolean);

            procedure Render (Name : in String;
                              Done : out Boolean) is
               use type Util.Strings.Name_Access;
            begin
               Done := False;
               for I in Generators'Range loop
                  exit when Generators (I).Name = null;
                  if Generators (I).Name.all = Name then
                     Generators (I).Generator.Render_Like (UI, Href, Context);
                     return;
                  end if;
               end loop;
               UI.Log_Error ("Like type {0} is not recognized", Name);
            end Render;

         begin
            if Kind'Length = 0 then
               UI.Log_Error ("The like type is empty.");
            else
               Util.Strings.Tokenizers.Iterate_Tokens (Content => Kind, Pattern => ",",
                                                       Process => Render'Access);
            end if;
         end;
      end if;
   end Encode_Begin;

   --  ------------------------------
   --  Register the like generator under the given name.
   --  ------------------------------
   procedure Register_Like (Name      : in Util.Strings.Name_Access;
                            Generator : in Like_Generator_Access) is
      use type Util.Strings.Name_Access;
   begin
      for I in Generators'Range loop
         if Generators (I).Name = null then
            Generators (I).Name := Name;
            Generators (I).Generator := Generator;
            return;
         end if;
      end loop;
   end Register_Like;

begin
   FACEBOOK_ATTRIBUTE_NAMES.Insert (FB_LAYOUT_ATTR'Access);
   FACEBOOK_ATTRIBUTE_NAMES.Insert (FB_SHOW_FACES_ATTR'Access);
   FACEBOOK_ATTRIBUTE_NAMES.Insert (FB_WIDTH_ATTR'Access);
   FACEBOOK_ATTRIBUTE_NAMES.Insert (FB_ACTION_ATTR'Access);
   FACEBOOK_ATTRIBUTE_NAMES.Insert (FB_FONT_ATTR'Access);
   FACEBOOK_ATTRIBUTE_NAMES.Insert (FB_COlORSCHEME_ATTR'Access);
   FACEBOOK_ATTRIBUTE_NAMES.Insert (FB_REF_ATTR'Access);
   FACEBOOK_ATTRIBUTE_NAMES.Insert (FB_KIDS_ATTR'Access);
   FACEBOOK_ATTRIBUTE_NAMES.Insert (FB_SEND_ATTR'Access);

   TWITTER_ATTRIBUTE_NAMES.Insert (TW_SIZE_ATTR'Access);
   TWITTER_ATTRIBUTE_NAMES.Insert (TW_COUNT_ATTR'Access);
   TWITTER_ATTRIBUTE_NAMES.Insert (TW_VIA_ATTR'Access);

   GOOGLE_ATTRIBUTE_NAMES.Insert (G_ANNOTATION_ATTR'Access);
   GOOGLE_ATTRIBUTE_NAMES.Insert (G_WIDTH_ATTR'Access);
end ASF.Components.Widgets.Likes;

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

with ASF.Requests;
with ASF.Contexts.Writer;
package body ASF.Components.Widgets.Likes is

   FB_LAYOUT_ATTR      : aliased constant String := "data-layout";
   FB_SHOW_FACES_ATTR  : aliased constant String := "data-show-faces";
   FB_WIDTH_ATTR       : aliased constant String := "data-width";
   FB_ACTION_ATTR      : aliased constant String := "data-action";
   FB_FONT_ATTR        : aliased constant String := "data-font";
   FB_COlORSCHEME_ATTR : aliased constant String := "data-colorscheme";
   FB_REF_ATTR         : aliased constant String := "data-ref";
   FB_KIDS_ATTR        : aliased constant String := "data-kid_directed_site";
   FB_SEND_ATTR        : aliased constant String := "data-send";

   TW_VIA_ATTR         : aliased constant String := "data-via";
   TW_COUNT_ATTR       : aliased constant String := "data-count";
   TW_SIZE_ATTR        : aliased constant String := "data-size";

   G_ANNOTATION_ATTR   : aliased constant String := "data-annotation";
   G_WIDTH_ATTR        : aliased constant String := "data-width";

   FACEBOOK_ATTRIBUTE_NAMES  : Util.Strings.String_Set.Set;
   FACEBOOK_SCRIPT_ATTRIBUTE : constant String := "asf.widgets.facebook.script";

   GOOGLE_ATTRIBUTE_NAMES    : Util.Strings.String_Set.Set;
   GOOGLE_SCRIPT_ATTRIBUTE   : constant String := "asf.widgets.google.script";

   TWITTER_ATTRIBUTE_NAMES    : Util.Strings.String_Set.Set;
   TWITTER_SCRIPT_ATTRIBUTE   : constant String := "asf.widgets.twitter.script";

   type Like_Generator_Binding is record
      Name      : Util.Strings.Name_Access;
      Generator : Like_Generator_Access;
   end record;

   type Like_Generator_Array is array (1 .. MAX_LIKE_GENERATOR) of Like_Generator_Binding;

   FB_NAME      : aliased constant String := "facebook";
   FB_GENERATOR : aliased Facebook_Like_Generator;

   G_NAME       : aliased constant String := "google+";
   G_GENERATOR  : aliased Google_Like_Generator;

   TWITTER_NAME       : aliased constant String := "twitter";
   TWITTER_GENERATOR  : aliased Twitter_Like_Generator;

   Generators : Like_Generator_Array := (1 => (FB_NAME'Access, FB_GENERATOR'Access),
                                         2 => (G_NAME'Access, G_GENERATOR'Access),
                                         3 => (TWITTER_NAME'Access, TWITTER_GENERATOR'Access),
                                         others => (null, null));

   --  ------------------------------
   --  Render the facebook like button according to the component attributes.
   --  ------------------------------
   overriding
   procedure Render_Like (Generator : in Facebook_Like_Generator;
                          UI        : in UILike'Class;
                          Href      : in String;
                          Context   : in out ASF.Contexts.Faces.Faces_Context'Class) is
      Writer  : constant Contexts.Writer.Response_Writer_Access := Context.Get_Response_Writer;
      Request : constant ASF.Requests.Request_Access := Context.Get_Request;
   begin
      if not Context.Is_Ajax_Request and then
        Util.Beans.Objects.Is_Null (Request.Get_Attribute (FACEBOOK_SCRIPT_ATTRIBUTE)) then

         Request.Set_Attribute (FACEBOOK_SCRIPT_ATTRIBUTE, Util.Beans.Objects.To_Object (True));
         Writer.Queue_Script ("(function(d, s, id) { var js, fjs = d.getElementsByTagName(s)[0];"
                              & "if (d.getElementById(id)) return;"
                              & "js = d.createElement(s); js.id = id;js.async=true;"
                              & "js.src = ""//connect.facebook.net/");
         Writer.Queue_Script (Util.Locales.To_String (Context.Get_Locale));
         Writer.Queue_Script ("/all.js#xfbml=1&;appId=116337738505130");
         Writer.Queue_Script (Generator.App_Id);
         Writer.Queue_Script (""";fjs.parentNode.insertBefore(js, fjs);"
                              & "}(document, 'script', 'facebook-jssdk'));");
         Writer.Start_Element ("div");
         Writer.Write_Attribute ("id", "fb-root");
         Writer.End_Element ("div");
      end if;
      Writer.Start_Element ("div");
      Writer.Write_Attribute ("class", "fb-like");
      Writer.Write_Attribute ("data-href", Href);
      UI.Render_Attributes (Context, FACEBOOK_ATTRIBUTE_NAMES, Writer);
      Writer.End_Element ("div");
   end Render_Like;

   --  ------------------------------
   --  Google like generator
   --  ------------------------------
   overriding
   procedure Render_Like (Generator : in Google_Like_Generator;
                          UI        : in UILike'Class;
                          Href      : in String;
                          Context   : in out ASF.Contexts.Faces.Faces_Context'Class) is
      pragma Unreferenced (Generator);

      Writer  : constant Contexts.Writer.Response_Writer_Access := Context.Get_Response_Writer;
      Request : constant ASF.Requests.Request_Access := Context.Get_Request;
   begin
      if not Context.Is_Ajax_Request and then
        Util.Beans.Objects.Is_Null (Request.Get_Attribute (GOOGLE_SCRIPT_ATTRIBUTE)) then

         Request.Set_Attribute (GOOGLE_SCRIPT_ATTRIBUTE, Util.Beans.Objects.To_Object (True));
         Writer.Queue_Include_Script ("https://apis.google.com/js/plusone.js");
      end if;
      Writer.Start_Element ("div");
      Writer.Write_Attribute ("class", "g-plusone");
      Writer.Write_Attribute ("data-href", Href);
      UI.Render_Attributes (Context, GOOGLE_ATTRIBUTE_NAMES, Writer);
      Writer.End_Element ("div");
   end Render_Like;

   --  ------------------------------
   --  Tweeter like generator
   --  ------------------------------
   overriding
   procedure Render_Like (Generator : in Twitter_Like_Generator;
                          UI        : in UILike'Class;
                          Href      : in String;
                          Context   : in out ASF.Contexts.Faces.Faces_Context'Class) is
      pragma Unreferenced (Generator);

      Writer  : constant Contexts.Writer.Response_Writer_Access := Context.Get_Response_Writer;
      Request : constant ASF.Requests.Request_Access := Context.Get_Request;
      Lang    : constant String := Util.Locales.Get_ISO3_Language (Context.Get_Locale);
   begin
      if not Context.Is_Ajax_Request and then
        Util.Beans.Objects.Is_Null (Request.Get_Attribute (TWITTER_SCRIPT_ATTRIBUTE)) then

         Request.Set_Attribute (TWITTER_SCRIPT_ATTRIBUTE, Util.Beans.Objects.To_Object (True));
         Writer.Queue_Script ("!function(d,s,id){var js,fjs=d.getElementsByTagName(s)[0],"
                              & "p=/^http:/.test(d.location)?'http':'https';"
                              & "if(!d.getElementById(id)){js=d.createElement(s);js.id=id;"
                              & "js.src=p+'://platform.twitter.com/widgets.js';"
                              & "fjs.parentNode.insertBefore(js,fjs);}}"
                              & "(document, 'script', 'twitter-wjs');");
      end if;
      Writer.Start_Element ("a");
      Writer.Write_Attribute ("href", "https://twitter.com/share");
      Writer.Write_Attribute ("class", "twitter-share-button");
      Writer.Write_Attribute ("data-url", Href);
      Writer.Write_Attribute ("data-lang", Lang);
      UI.Render_Attributes (Context, TWITTER_ATTRIBUTE_NAMES, Writer);
      Writer.Write_Text ("Tweet");
      Writer.End_Element ("a");
   end Render_Like;

   --  ------------------------------
   --  Get the link to submit in the like action.
   --  ------------------------------
   function Get_Link (UI      : in UILike;
                      Context : in ASF.Contexts.Faces.Faces_Context'Class) return String is
      Href : constant String := UI.Get_Attribute ("href", Context, "");
   begin
      if Href'Length > 0 then
         return Href;
      else
         return Context.Get_Request.Get_Request_URI;
      end if;
   end Get_Link;

   --  ------------------------------
   --  Render an image with the source link created from an email address to the Gravatars service.
   --  ------------------------------
   overriding
   procedure Encode_Begin (UI      : in UILike;
                           Context : in out ASF.Contexts.Faces.Faces_Context'Class) is
   begin
      if UI.Is_Rendered (Context) then
         declare
            Writer : constant Contexts.Writer.Response_Writer_Access := Context.Get_Response_Writer;
            Kind   : constant String := UI.Get_Attribute ("type", Context, "");
            Href   : constant String := UILike'Class (UI).Get_Link (Context);
            Style  : constant String := UI.Get_Attribute ("style", Context, "");
            Class  : constant String := UI.Get_Attribute ("styleClass", Context, "");

            procedure Render (Name : in String; Done : out Boolean);

            procedure Render (Name : in String;
                              Done : out Boolean) is
               use type Util.Strings.Name_Access;
            begin
               Done := False;
               for I in Generators'Range loop
                  exit when Generators (I).Name = null;
                  if Generators (I).Name.all = Name then
                     Writer.Start_Element ("div");
                     if Style'Length > 0 then
                        Writer.Write_Attribute ("style", Style);
                     end if;
                     if Class'Length > 0 then
                        Writer.Write_Attribute ("class", Class);
                     end if;
                     Generators (I).Generator.Render_Like (UI, Href, Context);
                     Writer.End_Element ("div");
                     return;
                  end if;
               end loop;
               UI.Log_Error ("Like type {0} is not recognized", Name);
            end Render;

         begin
            if Kind'Length = 0 then
               UI.Log_Error ("The like type is empty.");
            else
               Util.Strings.Tokenizers.Iterate_Tokens (Content => Kind, Pattern => ",",
                                                       Process => Render'Access);
            end if;
         end;
      end if;
   end Encode_Begin;

   --  ------------------------------
   --  Register the like generator under the given name.
   --  ------------------------------
   procedure Register_Like (Name      : in Util.Strings.Name_Access;
                            Generator : in Like_Generator_Access) is
      use type Util.Strings.Name_Access;
   begin
      for I in Generators'Range loop
         if Generators (I).Name = null then
            Generators (I).Name := Name;
            Generators (I).Generator := Generator;
            return;
         end if;
      end loop;
   end Register_Like;

begin
   FACEBOOK_ATTRIBUTE_NAMES.Insert (FB_LAYOUT_ATTR'Access);
   FACEBOOK_ATTRIBUTE_NAMES.Insert (FB_SHOW_FACES_ATTR'Access);
   FACEBOOK_ATTRIBUTE_NAMES.Insert (FB_WIDTH_ATTR'Access);
   FACEBOOK_ATTRIBUTE_NAMES.Insert (FB_ACTION_ATTR'Access);
   FACEBOOK_ATTRIBUTE_NAMES.Insert (FB_FONT_ATTR'Access);
   FACEBOOK_ATTRIBUTE_NAMES.Insert (FB_COlORSCHEME_ATTR'Access);
   FACEBOOK_ATTRIBUTE_NAMES.Insert (FB_REF_ATTR'Access);
   FACEBOOK_ATTRIBUTE_NAMES.Insert (FB_KIDS_ATTR'Access);
   FACEBOOK_ATTRIBUTE_NAMES.Insert (FB_SEND_ATTR'Access);

   TWITTER_ATTRIBUTE_NAMES.Insert (TW_SIZE_ATTR'Access);
   TWITTER_ATTRIBUTE_NAMES.Insert (TW_COUNT_ATTR'Access);
   TWITTER_ATTRIBUTE_NAMES.Insert (TW_VIA_ATTR'Access);

   GOOGLE_ATTRIBUTE_NAMES.Insert (G_ANNOTATION_ATTR'Access);
   GOOGLE_ATTRIBUTE_NAMES.Insert (G_WIDTH_ATTR'Access);
end ASF.Components.Widgets.Likes;

Add a div arround the social like button so that we can apply a style and class on it to control some positioning Use the style and styleClass attributes to put on the placement div


-----------------------------------------------------------------------
--  awa-workspaces-tests -- Unit tests for workspaces and invitations
--  Copyright (C) 2017 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Strings.Unbounded;
with Util.Test_Caller;
with Util.Strings;
with ADO;
with ASF.Requests.Mockup;
with ASF.Responses.Mockup;
with ASF.Principals;
with ASF.Helpers.Beans;
with ASF.Tests;
with AWA.Users.Models;
with AWA.Services.Contexts;
with AWA.Tests.Helpers.Users;
with Security.Contexts;
with AWA.Workspaces.Beans;

package body AWA.Workspaces.Tests is

   use Ada.Strings.Unbounded;
   use AWA.Tests;

   function Get_Invitation_Bean is
     new ASF.Helpers.Beans.Get_Request_Bean (Element_Type   => Beans.Invitation_Bean,
                                             Element_Access => Beans.Invitation_Bean_Access);

   package Caller is new Util.Test_Caller (Test, "Workspaces.Beans");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test AWA.Workspaces.Beans.Send",
                       Test_Invite_User'Access);
   end Add_Tests;

   --  ------------------------------
   --  Verify the anonymous access for the invitation page.
   --  ------------------------------
   procedure Verify_Anonymous (T    : in out Test;
                               Key  : in String) is
      Request   : ASF.Requests.Mockup.Request;
      Reply     : ASF.Responses.Mockup.Response;
   begin
      ASF.Tests.Do_Get (Request, Reply, "/auth/invitation.html", "invitation-view.html");
      ASF.Tests.Assert_Contains (T, "Bad or invalid invitation", Reply,
                                 "This invitation is invalid");

      ASF.Tests.Do_Get (Request, Reply, "/auth/invitation.html?key=test", "invitation-bad.html");
      ASF.Tests.Assert_Contains (T, "This invitation is invalid or has expired", Reply,
                                 "This invitation is invalid (key)");

      ASF.Tests.Do_Get (Request, Reply, "/auth/invitation.html?key=x" & key,
                        "invitation-bad2.html");
      ASF.Tests.Assert_Contains (T, "This invitation is invalid or has expired",
                                 Reply, "This invitation is invalid (key)");

      if Key = "" then
         return;
      end if;

      ASF.Tests.Do_Get (Request, Reply, "/auth/invitation.html?key=" & Key, "invitation-ok.html");
      ASF.Tests.Assert_Contains (T, "Accept invitation", Reply,
                                 "Accept invitation page is invalid");

   end Verify_Anonymous;

   --  ------------------------------
   --  Test sending an invitation.
   --  ------------------------------
   procedure Test_Invite_User (T : in out Test) is
      use type ADO.Identifier;
      use type AWA.Workspaces.Beans.Invitation_Bean_Access;

      Request   : ASF.Requests.Mockup.Request;
      Reply     : ASF.Responses.Mockup.Response;
      Invite    : AWA.Workspaces.Beans.Invitation_Bean_Access;
      Check     : AWA.Workspaces.Beans.Invitation_Bean;
   begin
      AWA.Tests.Helpers.Users.Login ("test-invite@test.com", Request);
      Request.Set_Parameter ("email", "invited-user@test.com");
      Request.Set_Parameter ("message", "I invite you to this application");
      Request.Set_Parameter ("send", "1");
      Request.Set_Parameter ("invite", "1");
      ASF.Tests.Do_Post (Request, Reply, "/workspaces/invite.html", "invite.html");

      T.Assert (Reply.Get_Status = ASF.Responses.SC_OK,
                "Invalid response after invitation creation");

      --  Verify the invitation by looking at the inviteUser bean.
      Invite := Get_Invitation_Bean (Request, "inviteUser");
      T.Assert (Invite /= null, "Null inviteUser bean");
      T.Assert (Invite.Get_Id /= ADO.NO_IDENTIFIER, "The invite ID is invalid");
      T.Assert (not Invite.Get_Access_Key.Is_Null, "The invite access key is null");
      Check.Key := Invite.Get_Access_Key.Get_Access_Key;
      T.Verify_Anonymous (Invite.Get_Access_Key.Get_Access_Key);
   end Test_Invite_User;

end AWA.Workspaces.Tests;

-----------------------------------------------------------------------
--  awa-workspaces-tests -- Unit tests for workspaces and invitations
--  Copyright (C) 2017 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Strings.Unbounded;
with Util.Test_Caller;
with Util.Strings;
with ADO;
with ASF.Requests.Mockup;
with ASF.Responses.Mockup;
with ASF.Principals;
with ASF.Helpers.Beans;
with ASF.Tests;
with AWA.Users.Models;
with AWA.Services.Contexts;
with AWA.Tests.Helpers.Users;
with Security.Contexts;
with AWA.Workspaces.Beans;

package body AWA.Workspaces.Tests is

   use Ada.Strings.Unbounded;
   use AWA.Tests;

   function Get_Invitation_Bean is
     new ASF.Helpers.Beans.Get_Request_Bean (Element_Type   => Beans.Invitation_Bean,
                                             Element_Access => Beans.Invitation_Bean_Access);

   package Caller is new Util.Test_Caller (Test, "Workspaces.Beans");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test AWA.Workspaces.Beans.Send",
                       Test_Invite_User'Access);
   end Add_Tests;

   --  ------------------------------
   --  Verify the anonymous access for the invitation page.
   --  ------------------------------
   procedure Verify_Anonymous (T    : in out Test;
                               Key  : in String) is
      Request   : ASF.Requests.Mockup.Request;
      Reply     : ASF.Responses.Mockup.Response;
   begin
      ASF.Tests.Do_Get (Request, Reply, "/auth/invitation.html", "invitation-view.html");
      ASF.Tests.Assert_Contains (T, "Bad or invalid invitation", Reply,
                                 "This invitation is invalid");

      ASF.Tests.Do_Get (Request, Reply, "/auth/invitation.html?key=test", "invitation-bad.html");
      ASF.Tests.Assert_Contains (T, "This invitation is invalid or has expired", Reply,
                                 "This invitation is invalid (key)");

      ASF.Tests.Do_Get (Request, Reply, "/auth/invitation.html?key=x" & key,
                        "invitation-bad2.html");
      ASF.Tests.Assert_Contains (T, "This invitation is invalid or has expired",
                                 Reply, "This invitation is invalid (key)");

      if Key = "" then
         return;
      end if;

      ASF.Tests.Do_Get (Request, Reply, "/auth/invitation.html?key=" & Key, "invitation-ok.html");
      ASF.Tests.Assert_Contains (T, "Accept invitation", Reply,
                                 "Accept invitation page is invalid");

   end Verify_Anonymous;

   --  ------------------------------
   --  Test sending an invitation.
   --  ------------------------------
   procedure Test_Invite_User (T : in out Test) is
      use type ADO.Identifier;
      use type AWA.Workspaces.Beans.Invitation_Bean_Access;

      Request   : ASF.Requests.Mockup.Request;
      Reply     : ASF.Responses.Mockup.Response;
      Invite    : AWA.Workspaces.Beans.Invitation_Bean_Access;
      Check     : AWA.Workspaces.Beans.Invitation_Bean;
   begin
      AWA.Tests.Helpers.Users.Login ("test-invite@test.com", Request);
      Request.Set_Parameter ("email", "invited-user@test.com");
      Request.Set_Parameter ("message", "I invite you to this application");
      Request.Set_Parameter ("send", "1");
      Request.Set_Parameter ("invite", "1");
      ASF.Tests.Do_Post (Request, Reply, "/workspaces/invite.html", "invite.html");

      T.Assert (Reply.Get_Status = ASF.Responses.SC_TEMPORARY_REDIRECT,
                "Invalid response after invitation creation");

      --  Verify the invitation by looking at the inviteUser bean.
      Invite := Get_Invitation_Bean (Request, "inviteUser");
      T.Assert (Invite /= null, "Null inviteUser bean");
      T.Assert (Invite.Get_Id /= ADO.NO_IDENTIFIER, "The invite ID is invalid");
      T.Assert (not Invite.Get_Access_Key.Is_Null, "The invite access key is null");
      Check.Key := Invite.Get_Access_Key.Get_Access_Key;
      T.Verify_Anonymous (Invite.Get_Access_Key.Get_Access_Key);
   end Test_Invite_User;

end AWA.Workspaces.Tests;

Fix unit test for invitation

Fix unit test for invitation


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

   Hex_Length : Positive := 16;

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

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

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

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

   --  ------------------------------
   --  Set the size of a target address to format them.
   --  ------------------------------
   procedure Set_Address_Size (Size : in Positive) is
   begin
      Hex_Length := Size;
   end Set_Address_Size;

   --  ------------------------------
   --  Format the PID into a string.
   --  ------------------------------
   function Pid (Value : in MAT.Types.Target_Process_Ref) return String is
   begin
      return Util.Strings.Image (Natural (Value));
   end Pid;

   --  ------------------------------
   --  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, Hex_Length);
   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 memory growth size into a string.
   --  ------------------------------
   function Size (Alloced : in MAT.Types.Target_Size;
                  Freed   : in MAT.Types.Target_Size) return String is
      use type MAT.Types.Target_Size;
   begin
      if Alloced > Freed then
         return Size (Alloced - Freed);
      elsif Alloced < Freed then
         return "-" & Size (Freed - Alloced);
      else
         return "=" & Size (Alloced);
      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 an event range description.
   --  ------------------------------
   function Event (First : in MAT.Events.Target_Event_Type;
                   Last  : in MAT.Events.Target_Event_Type) return String is
      use type MAT.Events.Event_Id_Type;

      Id1 : constant String := MAT.Events.Event_Id_Type'Image (First.Id);
      Id2 : constant String := MAT.Events.Event_Id_Type'Image (Last.Id);
   begin
      if First.Id = Last.Id then
         return Id1 (Id1'First + 1 .. Id1'Last);
      else
         return Id1 (Id1'First + 1 .. Id1'Last) & ".." & Id2 (Id2'First + 1 .. Id2'Last);
      end if;
   end Event;

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

         when MAT.Events.MSG_REALLOC =>
            if Mode = BRIEF then
               if Item.Old_Addr = 0 then
                  return "realloc";
               else
                  return "realloc";
               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.MSG_FREE =>
            if Mode = BRIEF then
               return "free";
            else
               return "free(" & Addr (Item.Addr) & "), " & Size (Item.Size);
            end if;

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

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

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

      end case;
   end Event;

   function Event_Malloc (Item       : in MAT.Events.Target_Event_Type;
                          Related    : in MAT.Events.Tools.Target_Event_Vector;
                          Start_Time : in MAT.Types.Target_Tick_Ref) return String is
      Free_Event : MAT.Events.Target_Event_Type;
   begin
      Free_Event := MAT.Events.Tools.Find (Related, MAT.Events.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.Event_Id_Type'Image (Free_Event.Id)
      ;

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

   end Event_Malloc;

   function Event_Free (Item       : in MAT.Events.Target_Event_Type;
                        Related    : in MAT.Events.Tools.Target_Event_Vector;
                        Start_Time : in MAT.Types.Target_Tick_Ref) return String is
      Alloc_Event : MAT.Events.Target_Event_Type;
   begin
      Alloc_Event := MAT.Events.Tools.Find (Related, MAT.Events.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.Event_Id_Type'Image (Alloc_Event.Id);

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

   end Event_Free;

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

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

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

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

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

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

      end case;
   end Event;

   --  ------------------------------
   --  Format the difference between two event IDs (offset).
   --  ------------------------------
   function Offset (First  : in MAT.Events.Event_Id_Type;
                    Second : in MAT.Events.Event_Id_Type) return String is
      use type MAT.Events.Event_Id_Type;
   begin
      if First = Second or First = 0 or Second = 0 then
         return "";
      elsif First > Second then
         return "+" & Util.Strings.Image (Natural (First - Second));
      else
         return "-" & Util.Strings.Image (Natural (Second - First));
      end if;
   end Offset;

   --  ------------------------------
   --  Format a short description of the memory allocation slot.
   --  ------------------------------
   function Slot (Value      : in MAT.Types.Target_Addr;
                  Item       : in MAT.Memory.Allocation;
                  Start_Time : in MAT.Types.Target_Tick_Ref) return String is
   begin
      return Addr (Value) & " is " & Size (Item.Size)
        & " bytes allocated after " & Duration (Item.Time - Start_Time)
        & " by event" & MAT.Events.Event_Id_Type'Image (Item.Event);
   end Slot;

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 : constant Boolean := True;

   Hex_Length : Positive := 16;

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

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

   --  Format a short description of a malloc event.
   function Event_Malloc (Item       : in MAT.Events.Target_Event_Type;
                          Related    : in MAT.Events.Tools.Target_Event_Vector;
                          Start_Time : in MAT.Types.Target_Tick_Ref) return String;

   --  Format a short description of a realloc event.
   function Event_Realloc (Item       : in MAT.Events.Target_Event_Type;
                           Related    : in MAT.Events.Tools.Target_Event_Vector;
                           Start_Time : in MAT.Types.Target_Tick_Ref) return String;

   --  Format a short description of a free event.
   function Event_Free (Item       : in MAT.Events.Target_Event_Type;
                        Related    : in MAT.Events.Tools.Target_Event_Vector;
                        Start_Time : in MAT.Types.Target_Tick_Ref) return String;

   --  ------------------------------
   --  Set the size of a target address to format them.
   --  ------------------------------
   procedure Set_Address_Size (Size : in Positive) is
   begin
      Hex_Length := Size;
   end Set_Address_Size;

   --  ------------------------------
   --  Format the PID into a string.
   --  ------------------------------
   function Pid (Value : in MAT.Types.Target_Process_Ref) return String is
   begin
      return Util.Strings.Image (Natural (Value));
   end Pid;

   --  ------------------------------
   --  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, Hex_Length);
   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 memory growth size into a string.
   --  ------------------------------
   function Size (Alloced : in MAT.Types.Target_Size;
                  Freed   : in MAT.Types.Target_Size) return String is
      use type MAT.Types.Target_Size;
   begin
      if Alloced > Freed then
         return "+" & Size (Alloced - Freed);
      elsif Alloced < Freed then
         return "-" & Size (Freed - Alloced);
      else
         return "=" & Size (Alloced);
      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 an event range description.
   --  ------------------------------
   function Event (First : in MAT.Events.Target_Event_Type;
                   Last  : in MAT.Events.Target_Event_Type) return String is
      use type MAT.Events.Event_Id_Type;

      Id1 : constant String := MAT.Events.Event_Id_Type'Image (First.Id);
      Id2 : constant String := MAT.Events.Event_Id_Type'Image (Last.Id);
   begin
      if First.Id = Last.Id then
         return Id1 (Id1'First + 1 .. Id1'Last);
      else
         return Id1 (Id1'First + 1 .. Id1'Last) & ".." & Id2 (Id2'First + 1 .. Id2'Last);
      end if;
   end Event;

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

         when MAT.Events.MSG_REALLOC =>
            if Mode = BRIEF then
               if Item.Old_Addr = 0 then
                  return "realloc";
               else
                  return "realloc";
               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.MSG_FREE =>
            if Mode = BRIEF then
               return "free";
            else
               return "free(" & Addr (Item.Addr) & "), " & Size (Item.Size);
            end if;

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

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

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

      end case;
   end Event;

   --  ------------------------------
   --  Format a short description of a malloc event.
   --  ------------------------------
   function Event_Malloc (Item       : in MAT.Events.Target_Event_Type;
                          Related    : in MAT.Events.Tools.Target_Event_Vector;
                          Start_Time : in MAT.Types.Target_Tick_Ref) return String is
      Free_Event : MAT.Events.Target_Event_Type;
   begin
      Free_Event := MAT.Events.Tools.Find (Related, MAT.Events.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.Event_Id_Type'Image (Free_Event.Id)
      ;

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

   end Event_Malloc;

   --  ------------------------------
   --  Format a short description of a realloc event.
   --  ------------------------------
   function Event_Realloc (Item       : in MAT.Events.Target_Event_Type;
                           Related    : in MAT.Events.Tools.Target_Event_Vector;
                           Start_Time : in MAT.Types.Target_Tick_Ref) return String is
      use type MAT.Events.Event_Id_Type;
      Free_Event : MAT.Events.Target_Event_Type;
   begin
      if Item.Next_Id = 0 and Item.Prev_Id = 0 then
         return Size (Item.Size) & " bytes reallocated after " & Duration (Item.Time - Start_Time)
           & " (never freed)";
      end if;

      Free_Event := MAT.Events.Tools.Find (Related, MAT.Events.MSG_FREE);
      return Size (Item.Size) & " bytes reallocated after " & Duration (Item.Time - Start_Time)
        & ", freed " & Duration (Free_Event.Time - Item.Time)
        & " after by event" & MAT.Events.Event_Id_Type'Image (Free_Event.Id)
        & " " & Size (Item.Size, Item.Old_Size) & " bytes";

   exception
      when MAT.Events.Tools.Not_Found =>
         return Size (Item.Size) & " bytes reallocated after " & Duration (Item.Time - Start_Time)
           & " (never freed) " & Size (Item.Size, Item.Old_Size) & " bytes";

   end Event_Realloc;

   --  ------------------------------
   --  Format a short description of a free event.
   --  ------------------------------
   function Event_Free (Item       : in MAT.Events.Target_Event_Type;
                        Related    : in MAT.Events.Tools.Target_Event_Vector;
                        Start_Time : in MAT.Types.Target_Tick_Ref) return String is
      Alloc_Event : MAT.Events.Target_Event_Type;
   begin
      Alloc_Event := MAT.Events.Tools.Find (Related, MAT.Events.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.Event_Id_Type'Image (Alloc_Event.Id);

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

   end Event_Free;

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

         when MAT.Events.MSG_REALLOC =>
            return Event_Realloc (Item, Related, Start_Time);

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

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

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

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

      end case;
   end Event;

   --  ------------------------------
   --  Format the difference between two event IDs (offset).
   --  ------------------------------
   function Offset (First  : in MAT.Events.Event_Id_Type;
                    Second : in MAT.Events.Event_Id_Type) return String is
      use type MAT.Events.Event_Id_Type;
   begin
      if First = Second or First = 0 or Second = 0 then
         return "";
      elsif First > Second then
         return "+" & Util.Strings.Image (Natural (First - Second));
      else
         return "-" & Util.Strings.Image (Natural (Second - First));
      end if;
   end Offset;

   --  ------------------------------
   --  Format a short description of the memory allocation slot.
   --  ------------------------------
   function Slot (Value      : in MAT.Types.Target_Addr;
                  Item       : in MAT.Memory.Allocation;
                  Start_Time : in MAT.Types.Target_Tick_Ref) return String is
   begin
      return Addr (Value) & " is " & Size (Item.Size)
        & " bytes allocated after " & Duration (Item.Time - Start_Time)
        & " by event" & MAT.Events.Event_Id_Type'Image (Item.Event);
   end Slot;

end MAT.Formats;

Declare the Event_Realloc function to format a realloc event Implement Event_Realloc and use it in Event to give a realloc event description


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

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

   Log   : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Util.Http.Clients");

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

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

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

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

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

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

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

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

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

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

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

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

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

   --  ------------------------------
   --  Initialize the client
   --  ------------------------------
   overriding
   procedure Initialize (Http : in out Client) is
   begin
      Http.Delegate := null;
      Http.Manager  := Default_Http_Manager;
      if Http.Manager = null then
         Log.Error ("No HTTP manager was defined");
         raise Program_Error with "No HTTP manager was defined.";
      end if;
      Http.Manager.Create (Http);
   end Initialize;

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

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

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

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

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

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

end Util.Http.Clients;

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

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

   Log   : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Util.Http.Clients");

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

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

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

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

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

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

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

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

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

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

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

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

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

   --  ------------------------------
   --  Initialize the client
   --  ------------------------------
   overriding
   procedure Initialize (Http : in out Client) is
   begin
      Http.Delegate := null;
      Http.Manager  := Default_Http_Manager;
      if Http.Manager = null then
         Log.Error ("No HTTP manager was defined");
         raise Program_Error with "No HTTP manager was defined.";
      end if;
      Http.Manager.Create (Http);
   end Initialize;

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

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

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

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

   --  ------------------------------
   --  Set the timeout for the connection.
   --  ------------------------------
   procedure Set_Timeout (Request : in out Client;
                          Timeout : in Duration) is
   begin
      Request.Manager.Set_Timeout (Request, Timeout);
   end Set_Timeout;

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

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

end Util.Http.Clients;

Implement the Set_Timeout procedure

Implement the Set_Timeout procedure