------------------------------------------------------------------------------
-- Copyright (c) 2015-2017, Natacha Porté                                   --
--                                                                          --
-- Permission to use, copy, modify, and distribute this software for any    --
-- purpose with or without fee is hereby granted, provided that the above   --
-- copyright notice and this permission notice appear in all copies.        --
--                                                                          --
-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES --
-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF         --
-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR  --
-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES   --
-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN    --
-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF  --
-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.           --
------------------------------------------------------------------------------

with Ada.Calendar;
with Natools.S_Expressions.Atom_Refs;
with Natools.S_Expressions.Caches;
with Natools.S_Expressions.Conditionals.Strings;
with Natools.S_Expressions.Lockable;
with Natools.S_Expressions.Templates.Dates;
with Natools.Static_Maps.Web.Fallback_Render;
with Natools.Web.ACL;
with Natools.Web.Comment_Cookies;
with Natools.Web.Escapes;
with Natools.Web.Filters.Stores;
with Natools.Web.Tags;
with Natools.Web.String_Tables;

procedure Natools.Web.Fallback_Render
  (Exchange : in out Natools.Web.Sites.Exchange;
   Name : in Natools.S_Expressions.Atom;
   Arguments : in out Natools.S_Expressions.Lockable.Descriptor'Class;
   Context : in String := "";
   Re_Enter : access procedure
     (Exchange : in out Natools.Web.Sites.Exchange;
      Expression : in out Natools.S_Expressions.Lockable.Descriptor'Class)
     := null;
   Elements : in Natools.Web.Containers.Expression_Maps.Constant_Map
     := Natools.Web.Containers.Expression_Maps.Empty_Constant_Map;
   Severity : in Severities.Code := Severities.Error)
is
   package Commands renames Natools.Static_Maps.Web.Fallback_Render;
   use type S_Expressions.Events.Event;

   procedure Render_Ref (Ref : in S_Expressions.Atom_Refs.Immutable_Reference);
   procedure Report_Unknown_Command;

   procedure Render_Ref
     (Ref : in S_Expressions.Atom_Refs.Immutable_Reference) is
   begin
      if not Ref.Is_Empty then
         Escapes.Write
           (Exchange,
            S_Expressions.To_String (Ref.Query),
            Escapes.HTML_Attribute);
      elsif Re_Enter /= null then
         Re_Enter (Exchange, Arguments);
      end if;
   end Render_Ref;

   procedure Report_Unknown_Command is
   begin
      if Context /= "" then
         Log (Severity, "Unknown render command """
           & S_Expressions.To_String (Name)
           & """ in "
           & Context);
      end if;
   end Report_Unknown_Command;
begin
   case Commands.To_Command (S_Expressions.To_String (Name)) is
      when Commands.Unknown =>
         Report_Unknown_Command;

      when Commands.Current_Time =>
         S_Expressions.Templates.Dates.Render
           (Exchange, Arguments, Ada.Calendar.Clock);

      when Commands.Cookies =>
         String_Tables.Render
           (Exchange,
            String_Tables.Create (Exchange.Cookie_Table),
            Arguments);

      when Commands.Comment_Cookie_Filter =>
         Render_Ref (Comment_Cookies.Filter (Sites.Comment_Info (Exchange)));

      when Commands.Comment_Cookie_Link =>
         Render_Ref (Comment_Cookies.Link (Sites.Comment_Info (Exchange)));

      when Commands.Comment_Cookie_Mail =>
         Render_Ref (Comment_Cookies.Mail (Sites.Comment_Info (Exchange)));

      when Commands.Comment_Cookie_Name =>
         Render_Ref (Comment_Cookies.Name (Sites.Comment_Info (Exchange)));

      when Commands.Element =>
         if Re_Enter = null then
            Report_Unknown_Command;
         else
            declare
               Template : S_Expressions.Caches.Cursor
                 := Exchange.Site.Get_Template
                    (Elements,
                     Arguments,
                     Lookup_Template => False);
            begin
               Re_Enter (Exchange, Template);
            end;
         end if;

      when Commands.Element_Or_Template =>
         if Re_Enter = null then
            Report_Unknown_Command;
         else
            declare
               Template : S_Expressions.Caches.Cursor
                 := Exchange.Site.Get_Template (Elements, Arguments);
            begin
               Re_Enter (Exchange, Template);
            end;
         end if;

      when Commands.Filter =>
         if Re_Enter = null then
            Report_Unknown_Command;
         elsif Arguments.Current_Event = S_Expressions.Events.Add_Atom then
            begin
               declare
                  Filter : Filters.Filter'Class
                    := Exchange.Site.Get_Filter (Arguments.Current_Atom);
               begin
                  Arguments.Next;
                  Exchange.Insert_Filter (Filter);
                  Re_Enter (Exchange, Arguments);
                  Exchange.Remove_Filter (Filter);
               end;
            exception
               when Filters.Stores.No_Filter => null;
            end;
         end if;

      when Commands.If_Comment_Cookie_Filter_Is =>
         if Re_Enter = null then
            Report_Unknown_Command;
         elsif Arguments.Current_Event = S_Expressions.Events.Add_Atom then
            declare
               use type S_Expressions.Atom;
               Ref : constant S_Expressions.Atom_Refs.Immutable_Reference
                 := Comment_Cookies.Filter (Sites.Comment_Info (Exchange));
            begin
               if not Ref.Is_Empty
                 and then Ref.Query = Arguments.Current_Atom
               then
                  Arguments.Next;
                  Re_Enter (Exchange, Arguments);
               end if;
            end;
         end if;

      when Commands.If_Has_Element =>
         if Re_Enter = null then
            Report_Unknown_Command;
         elsif Arguments.Current_Event = S_Expressions.Events.Add_Atom
           and then Elements.Contains (Arguments.Current_Atom)
         then
            Arguments.Next;
            Re_Enter (Exchange, Arguments);
         end if;

      when Commands.If_Has_Not_Element =>
         if Re_Enter = null then
            Report_Unknown_Command;
         elsif Arguments.Current_Event = S_Expressions.Events.Add_Atom
           and then not Elements.Contains (Arguments.Current_Atom)
         then
            Arguments.Next;
            Re_Enter (Exchange, Arguments);
         end if;

      when Commands.If_Header_Else =>
         if Re_Enter = null then
            Report_Unknown_Command;
         elsif Arguments.Current_Event = S_Expressions.Events.Open_List then
            declare
               Lock : S_Expressions.Lockable.Lock_State;
               Event : S_Expressions.Events.Event;
               Condition : Boolean;
            begin
               Arguments.Next (Event);
               if Event /= S_Expressions.Events.Add_Atom then
                  return;
               end if;

               Arguments.Lock (Lock);

               Evaluate_Condition :
               declare
                  Value : constant String := Exchange.Header
                    (S_Expressions.To_String (Arguments.Current_Atom));
               begin
                  Arguments.Next;
                  Condition := S_Expressions.Conditionals.Strings.Evaluate
                    (Value, Arguments);
                  Arguments.Unlock (Lock);
               exception
                  when others =>
                     Arguments.Unlock (Lock, False);
                     raise;
               end Evaluate_Condition;

               Arguments.Next (Event);

               case Event is
                  when S_Expressions.Events.Add_Atom =>
                     if Condition then
                        Exchange.Append (Arguments.Current_Atom);
                     end if;

                  when S_Expressions.Events.Open_List =>
                     if Condition then
                        Arguments.Lock (Lock);
                        begin
                           Arguments.Next;
                           Re_Enter (Exchange, Arguments);
                           Arguments.Unlock (Lock);
                        exception
                           when others =>
                              Arguments.Unlock (Lock, False);
                              raise;
                        end;
                     else
                        Arguments.Close_Current_List;
                     end if;

                  when S_Expressions.Events.Close_List
                    | S_Expressions.Events.End_Of_Input
                    | S_Expressions.Events.Error
                  =>
                     return;
               end case;

               if Condition then
                  return;
               end if;

               Arguments.Next (Event);

               case Event is
                  when S_Expressions.Events.Add_Atom =>
                     Exchange.Append (Arguments.Current_Atom);

                  when S_Expressions.Events.Open_List =>
                     Arguments.Lock (Lock);
                     begin
                        Arguments.Next;
                        Re_Enter (Exchange, Arguments);
                        Arguments.Unlock (Lock);
                     exception
                        when others =>
                           Arguments.Unlock (Lock, False);
                           raise;
                     end;

                  when S_Expressions.Events.Close_List
                    | S_Expressions.Events.End_Of_Input
                    | S_Expressions.Events.Error
                  =>
                     return;
               end case;
            end;
         end if;

      when Commands.If_Parameter_Is =>
         if Re_Enter = null then
            Report_Unknown_Command;
         elsif Arguments.Current_Event = S_Expressions.Events.Add_Atom then
            declare
               Param_Value : constant String := Exchange.Parameter
                 (S_Expressions.To_String (Arguments.Current_Atom));
               Event : S_Expressions.Events.Event;
            begin
               Arguments.Next (Event);
               if Event = S_Expressions.Events.Add_Atom
                 and then Param_Value
                    = S_Expressions.To_String (Arguments.Current_Atom)
               then
                  Arguments.Next;
                  Re_Enter (Exchange, Arguments);
               end if;
            end;
         end if;

      when Commands.Load_Date =>
         S_Expressions.Templates.Dates.Render
           (Exchange, Arguments, Exchange.Site.Load_Date);

      when Commands.Optional_Tags =>
         Tags.Render
           (Exchange, Exchange.Site.Get_Tags, Arguments, Optional => True);

      when Commands.Parameter =>
         if Arguments.Current_Event = S_Expressions.Events.Add_Atom then
            declare
               Parameter_Name : constant String
                 := S_Expressions.To_String (Arguments.Current_Atom);
            begin
               if Exchange.Has_Parameter (Parameter_Name) then
                  Escapes.Write
                    (Exchange,
                     Exchange.Parameter (Parameter_Name),
                     Escapes.HTML_Attribute);
               elsif Re_Enter /= null then
                  Arguments.Next;
                  Re_Enter (Exchange, Arguments);
               end if;
            end;
         end if;

      when Commands.Set_MIME_Type =>
         if Arguments.Current_Event = S_Expressions.Events.Add_Atom then
            Exchange.Set_MIME_Type (Arguments.Current_Atom);
         end if;

      when Commands.Tags =>
         Tags.Render (Exchange, Exchange.Site.Get_Tags, Arguments);

      when Commands.Template =>
         if Re_Enter = null then
            Report_Unknown_Command;
         else
            declare
               Template : S_Expressions.Caches.Cursor
                 := Exchange.Site.Get_Template
                    (Elements,
                     Arguments,
                     Lookup_Element => False);
            begin
               Re_Enter (Exchange, Template);
            end;
         end if;

      when Commands.User =>
         if Re_Enter = null then
            Report_Unknown_Command;
         else
            declare
               Match : Boolean := False;
            begin
               ACL.Match (Sites.Identity (Exchange), Arguments, Match);

               if Match then
                  Arguments.Next;
                  Re_Enter (Exchange, Arguments);
               end if;
            end;
         end if;
   end case;
end Natools.Web.Fallback_Render;

------------------------------------------------------------------------------
-- Copyright (c) 2015-2017, Natacha Porté                                   --
--                                                                          --
-- Permission to use, copy, modify, and distribute this software for any    --
-- purpose with or without fee is hereby granted, provided that the above   --
-- copyright notice and this permission notice appear in all copies.        --
--                                                                          --
-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES --
-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF         --
-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR  --
-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES   --
-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN    --
-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF  --
-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.           --
------------------------------------------------------------------------------

with Ada.Calendar;
with Natools.S_Expressions.Atom_Refs;
with Natools.S_Expressions.Caches;
with Natools.S_Expressions.Conditionals.Strings;
with Natools.S_Expressions.Lockable;
with Natools.S_Expressions.Templates.Dates;
with Natools.Static_Maps.Web.Fallback_Render;
with Natools.Web.ACL;
with Natools.Web.Comment_Cookies;
with Natools.Web.Escapes;
with Natools.Web.Filters.Stores;
with Natools.Web.Tags;
with Natools.Web.String_Tables;

procedure Natools.Web.Fallback_Render
  (Exchange : in out Natools.Web.Sites.Exchange;
   Name : in Natools.S_Expressions.Atom;
   Arguments : in out Natools.S_Expressions.Lockable.Descriptor'Class;
   Context : in String := "";
   Re_Enter : access procedure
     (Exchange : in out Natools.Web.Sites.Exchange;
      Expression : in out Natools.S_Expressions.Lockable.Descriptor'Class)
     := null;
   Elements : in Natools.Web.Containers.Expression_Maps.Constant_Map
     := Natools.Web.Containers.Expression_Maps.Empty_Constant_Map;
   Severity : in Severities.Code := Severities.Error)
is
   package Commands renames Natools.Static_Maps.Web.Fallback_Render;
   use type S_Expressions.Events.Event;

   procedure Render_Then_Else (Condition : in Boolean);
   procedure Render_Ref (Ref : in S_Expressions.Atom_Refs.Immutable_Reference);
   procedure Report_Unknown_Command;

   procedure Render_Then_Else (Condition : in Boolean) is
      Lock : S_Expressions.Lockable.Lock_State;
      Event : S_Expressions.Events.Event;
   begin
      Arguments.Next (Event);

      case Event is
         when S_Expressions.Events.Add_Atom =>
            if Condition then
               Exchange.Append (Arguments.Current_Atom);
            end if;

         when S_Expressions.Events.Open_List =>
            if Condition then
               Arguments.Lock (Lock);
               begin
                  Arguments.Next;
                  Re_Enter (Exchange, Arguments);
                  Arguments.Unlock (Lock);
               exception
                  when others =>
                     Arguments.Unlock (Lock, False);
                     raise;
               end;
            else
               Arguments.Close_Current_List;
            end if;

         when S_Expressions.Events.Close_List
           | S_Expressions.Events.End_Of_Input
           | S_Expressions.Events.Error
         =>
            return;
      end case;

      if Condition then
         return;
      end if;

      Arguments.Next (Event);

      case Event is
         when S_Expressions.Events.Add_Atom =>
            Exchange.Append (Arguments.Current_Atom);

         when S_Expressions.Events.Open_List =>
            Arguments.Lock (Lock);
            begin
               Arguments.Next;
               Re_Enter (Exchange, Arguments);
               Arguments.Unlock (Lock);
            exception
               when others =>
                  Arguments.Unlock (Lock, False);
                  raise;
            end;

         when S_Expressions.Events.Close_List
           | S_Expressions.Events.End_Of_Input
           | S_Expressions.Events.Error
         =>
            return;
      end case;
   end Render_Then_Else;

   procedure Render_Ref
     (Ref : in S_Expressions.Atom_Refs.Immutable_Reference) is
   begin
      if not Ref.Is_Empty then
         Escapes.Write
           (Exchange,
            S_Expressions.To_String (Ref.Query),
            Escapes.HTML_Attribute);
      elsif Re_Enter /= null then
         Re_Enter (Exchange, Arguments);
      end if;
   end Render_Ref;

   procedure Report_Unknown_Command is
   begin
      if Context /= "" then
         Log (Severity, "Unknown render command """
           & S_Expressions.To_String (Name)
           & """ in "
           & Context);
      end if;
   end Report_Unknown_Command;
begin
   case Commands.To_Command (S_Expressions.To_String (Name)) is
      when Commands.Unknown =>
         Report_Unknown_Command;

      when Commands.Current_Time =>
         S_Expressions.Templates.Dates.Render
           (Exchange, Arguments, Ada.Calendar.Clock);

      when Commands.Cookies =>
         String_Tables.Render
           (Exchange,
            String_Tables.Create (Exchange.Cookie_Table),
            Arguments);

      when Commands.Comment_Cookie_Filter =>
         Render_Ref (Comment_Cookies.Filter (Sites.Comment_Info (Exchange)));

      when Commands.Comment_Cookie_Link =>
         Render_Ref (Comment_Cookies.Link (Sites.Comment_Info (Exchange)));

      when Commands.Comment_Cookie_Mail =>
         Render_Ref (Comment_Cookies.Mail (Sites.Comment_Info (Exchange)));

      when Commands.Comment_Cookie_Name =>
         Render_Ref (Comment_Cookies.Name (Sites.Comment_Info (Exchange)));

      when Commands.Element =>
         if Re_Enter = null then
            Report_Unknown_Command;
         else
            declare
               Template : S_Expressions.Caches.Cursor
                 := Exchange.Site.Get_Template
                    (Elements,
                     Arguments,
                     Lookup_Template => False);
            begin
               Re_Enter (Exchange, Template);
            end;
         end if;

      when Commands.Element_Or_Template =>
         if Re_Enter = null then
            Report_Unknown_Command;
         else
            declare
               Template : S_Expressions.Caches.Cursor
                 := Exchange.Site.Get_Template (Elements, Arguments);
            begin
               Re_Enter (Exchange, Template);
            end;
         end if;

      when Commands.Filter =>
         if Re_Enter = null then
            Report_Unknown_Command;
         elsif Arguments.Current_Event = S_Expressions.Events.Add_Atom then
            begin
               declare
                  Filter : Filters.Filter'Class
                    := Exchange.Site.Get_Filter (Arguments.Current_Atom);
               begin
                  Arguments.Next;
                  Exchange.Insert_Filter (Filter);
                  Re_Enter (Exchange, Arguments);
                  Exchange.Remove_Filter (Filter);
               end;
            exception
               when Filters.Stores.No_Filter => null;
            end;
         end if;

      when Commands.If_Comment_Cookie_Filter_Is =>
         if Re_Enter = null then
            Report_Unknown_Command;
         elsif Arguments.Current_Event = S_Expressions.Events.Add_Atom then
            declare
               use type S_Expressions.Atom;
               Ref : constant S_Expressions.Atom_Refs.Immutable_Reference
                 := Comment_Cookies.Filter (Sites.Comment_Info (Exchange));
            begin
               if not Ref.Is_Empty
                 and then Ref.Query = Arguments.Current_Atom
               then
                  Arguments.Next;
                  Re_Enter (Exchange, Arguments);
               end if;
            end;
         end if;

      when Commands.If_Has_Element =>
         if Re_Enter = null then
            Report_Unknown_Command;
         elsif Arguments.Current_Event = S_Expressions.Events.Add_Atom
           and then Elements.Contains (Arguments.Current_Atom)
         then
            Arguments.Next;
            Re_Enter (Exchange, Arguments);
         end if;

      when Commands.If_Has_Not_Element =>
         if Re_Enter = null then
            Report_Unknown_Command;
         elsif Arguments.Current_Event = S_Expressions.Events.Add_Atom
           and then not Elements.Contains (Arguments.Current_Atom)
         then
            Arguments.Next;
            Re_Enter (Exchange, Arguments);
         end if;

      when Commands.If_Header_Else =>
         if Re_Enter = null then
            Report_Unknown_Command;
         elsif Arguments.Current_Event = S_Expressions.Events.Open_List then
            declare
               Lock : S_Expressions.Lockable.Lock_State;
               Event : S_Expressions.Events.Event;
               Condition : Boolean;
            begin
               Arguments.Next (Event);
               if Event /= S_Expressions.Events.Add_Atom then
                  return;
               end if;

               Arguments.Lock (Lock);

               Evaluate_Condition :
               declare
                  Value : constant String := Exchange.Header
                    (S_Expressions.To_String (Arguments.Current_Atom));
               begin
                  Arguments.Next;
                  Condition := S_Expressions.Conditionals.Strings.Evaluate
                    (Value, Arguments);
                  Arguments.Unlock (Lock);
               exception
                  when others =>
                     Arguments.Unlock (Lock, False);
                     raise;
               end Evaluate_Condition;

               Render_Then_Else (Condition);
            end;
         end if;

      when Commands.If_Parameter_Is =>
         if Re_Enter = null then
            Report_Unknown_Command;
         elsif Arguments.Current_Event = S_Expressions.Events.Add_Atom then
            declare
               Param_Value : constant String := Exchange.Parameter
                 (S_Expressions.To_String (Arguments.Current_Atom));
               Event : S_Expressions.Events.Event;
            begin
               Arguments.Next (Event);
               if Event = S_Expressions.Events.Add_Atom
                 and then Param_Value
                    = S_Expressions.To_String (Arguments.Current_Atom)
               then
                  Arguments.Next;
                  Re_Enter (Exchange, Arguments);
               end if;
            end;
         end if;

      when Commands.Load_Date =>
         S_Expressions.Templates.Dates.Render
           (Exchange, Arguments, Exchange.Site.Load_Date);

      when Commands.Optional_Tags =>
         Tags.Render
           (Exchange, Exchange.Site.Get_Tags, Arguments, Optional => True);

      when Commands.Parameter =>
         if Arguments.Current_Event = S_Expressions.Events.Add_Atom then
            declare
               Parameter_Name : constant String
                 := S_Expressions.To_String (Arguments.Current_Atom);
            begin
               if Exchange.Has_Parameter (Parameter_Name) then
                  Escapes.Write
                    (Exchange,
                     Exchange.Parameter (Parameter_Name),
                     Escapes.HTML_Attribute);
               elsif Re_Enter /= null then
                  Arguments.Next;
                  Re_Enter (Exchange, Arguments);
               end if;
            end;
         end if;

      when Commands.Set_MIME_Type =>
         if Arguments.Current_Event = S_Expressions.Events.Add_Atom then
            Exchange.Set_MIME_Type (Arguments.Current_Atom);
         end if;

      when Commands.Tags =>
         Tags.Render (Exchange, Exchange.Site.Get_Tags, Arguments);

      when Commands.Template =>
         if Re_Enter = null then
            Report_Unknown_Command;
         else
            declare
               Template : S_Expressions.Caches.Cursor
                 := Exchange.Site.Get_Template
                    (Elements,
                     Arguments,
                     Lookup_Element => False);
            begin
               Re_Enter (Exchange, Template);
            end;
         end if;

      when Commands.User =>
         if Re_Enter = null then
            Report_Unknown_Command;
         else
            declare
               Match : Boolean := False;
            begin
               ACL.Match (Sites.Identity (Exchange), Arguments, Match);

               if Match then
                  Arguments.Next;
                  Re_Enter (Exchange, Arguments);
               end if;
            end;
         end if;
   end case;
end Natools.Web.Fallback_Render;

fallback_render: refactor the then/else render in a dedicated procedure


------------------------------------------------------------------------------
--                                                                          --
--                    Copyright (C) 2015, 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    stm32f429i_discovery_lcd.c                                    --
--   @author  MCD Application Team                                          --
--   @version V1.1.0                                                        --
--   @date    19-June-2014                                                  --
--   @brief   This file includes the LTDC driver to control LCD display.    --         --
--                                                                          --
--   COPYRIGHT(c) 2014 STMicroelectronics                                   --
------------------------------------------------------------------------------

with Ada.Unchecked_Conversion;
with Ada.Real_Time;  use Ada.Real_Time;

with STM32_SVD.LTDC; use STM32_SVD.LTDC;
with STM32_SVD.RCC;  use STM32_SVD.RCC;

with STM32.SDRAM;    use STM32.SDRAM;

package body STM32.LTDC is

   Frame_Buffer_Array : array (LCD_Layer) of Frame_Buffer_Access;
   Current_Pixel_Fmt  : Pixel_Format := Pixel_Fmt_ARGB1555;
   Swap_X_Y           : Boolean := False;

   type FB32 is array (Natural range 0 .. LCD_Height - 1,
                       Natural range 0 .. LCD_Width - 1) of Word
     with Component_Size => 32, Volatile;
   type Swap_FB32 is array (Natural range 0 .. LCD_Width - 1,
                            Natural range 0 .. LCD_Height - 1) of Word
     with Component_Size => 32, Volatile;
   type FB24 is array (Natural range 0 .. LCD_Height - 1,
                       Natural range 0 .. (LCD_Width * 3) - 1) of Byte
     with Component_Size => 8, Volatile;
   type Swap_FB24 is array (Natural range 0 .. LCD_Width - 1,
                            Natural range 0 .. LCD_Height * 3 - 1) of Byte
     with Component_Size => 8, Volatile;
   type FB16 is array (Natural range 0 .. LCD_Height - 1,
                       Natural range 0 .. LCD_Width - 1) of Short
     with Component_Size => 16, Volatile;
   type Swap_FB16 is array (Natural range 0 .. LCD_Width - 1,
                            Natural range 0 .. LCD_Height - 1) of Short
     with Component_Size => 16, Volatile;

   type Frame_Buffer (Pixel_Fmt : Pixel_Format;
                      Swap      : Boolean) is record
      case Swap is
         when False =>
            case Pixel_Fmt is
            when Pixel_Fmt_ARGB8888 =>
               Arr32 : FB32;
            when Pixel_Fmt_RGB888 =>
               Arr24 : FB24;
            when others =>
               Arr16 : FB16;
            end case;
         when True =>
            case Pixel_Fmt is
            when Pixel_Fmt_ARGB8888 =>
               SwArr32 : Swap_FB32;
            when Pixel_Fmt_RGB888 =>
               SwArr24 : Swap_FB24;
            when others =>
               SwArr16 : Swap_FB16;
            end case;
      end case;
   end record with Unchecked_Union, Volatile;

   type Frame_Buffer_Int_Access is access all Frame_Buffer;

   function Pixel_Size (Fmt : Pixel_Format) return Positive;

   ----------
   -- Init --
   ----------

   package Init is
      BF1_Constant_Alpha : constant := 2#100#;
      BF2_Constant_Alpha : constant := 2#101#;
      BF1_Pixel_Alpha    : constant := 2#110#;
      BF2_Pixel_Alpha    : constant := 2#111#;

      procedure Reload_Config (Immediate : Boolean);

      procedure Set_Layer_CFBA
        (Layer : LCD_Layer;
         FBA   : Frame_Buffer_Access);
      --  Sets the frame buffer of the specified layer

      function Get_Layer_CFBA
        (Layer : LCD_Layer) return Frame_Buffer_Access;
      --  Gets the frame buffer of the specified layer

      procedure LTDC_Init;

      procedure Layer_Init
        (Layer    : LCD_Layer;
         Config   : Pixel_Format;
         BF1, BF2 : UInt3);

      procedure Set_Layer_State
        (Layer : LCD_Layer;
         State : Boolean);
      --  Enables/Disables the specified layer

   end Init;

   package body Init is separate;

   -------------------
   -- Reload_Config --
   -------------------

   procedure Reload_Config
     (Immediate : Boolean := True)
      renames Init.Reload_Config;

   ---------------------
   -- Set_Layer_State --
   ---------------------

   procedure Set_Layer_State
     (Layer : LCD_Layer;
      State : Layer_State)
   is
   begin
      Init.Set_Layer_State (Layer, State = Enabled);
   end Set_Layer_State;

   ----------------
   -- Initialize --
   ----------------

   procedure Initialize (Pixel_Fmt : Pixel_Format := Pixel_Fmt_ARGB1555)
   is
      FB_Size : constant Word :=
                  Word
                    (LCD_Width * LCD_Height * Pixel_Size (Pixel_Fmt));
   begin
      if Initialized then
         return;
      end if;

      Pre_LTDC_Initialize;

      delay until Clock + Milliseconds (200);

      Init.LTDC_Init;
      STM32.SDRAM.Initialize;

      Current_Pixel_Fmt := Pixel_Fmt;

      Frame_Buffer_Array (Layer1) := STM32.SDRAM.Reserve (FB_Size);

      Init.Layer_Init
        (Layer1, Pixel_Fmt,
         Init.BF1_Constant_Alpha,
         Init.BF2_Constant_Alpha);
      Init.Layer_Init
        (Layer2, Pixel_Fmt,
         Init.BF1_Pixel_Alpha,
         Init.BF2_Pixel_Alpha);

      Init.Set_Layer_State (Layer1, True);
      Init.Set_Layer_State (Layer2, False);

      Reload_Config (True);

      --  enable Dither
      LTDC_Periph.GCR.DEN := 1;

      Reload_Config (True);

      Post_LTDC_Initialize;
   end Initialize;

   -----------------
   -- Initialized --
   -----------------

   function Initialized return Boolean is
   begin
      return Frame_Buffer_Array (Layer1) /= Null_Address;
   end Initialized;

   ----------------
   -- Pixel_Size --
   ----------------

   function Pixel_Size (Fmt : Pixel_Format) return Positive is
     (case Fmt is
         when Pixel_Fmt_ARGB8888 => 4,
         when Pixel_Fmt_RGB888   => 3,
         when Pixel_Fmt_RGB565 | Pixel_Fmt_ARGB1555 | Pixel_Fmt_ARGB4444 => 2);

   -------------------
   -- Get_Pixel_Fmt --
   -------------------

   function Get_Pixel_Fmt return Pixel_Format is
      (Current_Pixel_Fmt);

   --------------------------
   -- Current_Frame_Buffer --
   --------------------------

   function Current_Frame_Buffer
     (Layer : LCD_Layer)
      return Frame_Buffer_Access
     renames Init.Get_Layer_CFBA;

   ----------------------
   -- Set_Frame_Buffer --
   ----------------------

   procedure Set_Frame_Buffer
     (Layer : LCD_Layer; Addr : Frame_Buffer_Access)
      renames Init.Set_Layer_CFBA;

   ---------------------
   -- Set_Orientation --
   ---------------------

   procedure Set_Orientation (Orientation : Orientation_Mode)
   is
   begin
      case Orientation is
         when Portrait =>
            Swap_X_Y := LCD_Width > LCD_Height;
         when Landscape =>
            Swap_X_Y := LCD_Height > LCD_Width;
      end case;
   end Set_Orientation;

   ---------------------
   -- Get_Orientation --
   ---------------------

   function Get_Orientation return Orientation_Mode
   is
   begin
      return (if Pixel_Width > Pixel_Height then Landscape else Portrait);
   end Get_Orientation;

   ------------
   -- SwapXY --
   ------------

   function SwapXY return Boolean
   is (Swap_X_Y);

   -----------------
   -- Pixel_Width --
   -----------------

   function Pixel_Width return Natural
   is (if Swap_X_Y then LCD_Height else LCD_Width);

   ------------------
   -- Pixel_Height --
   ------------------

   function Pixel_Height return Natural
   is (if Swap_X_Y then LCD_Width else LCD_Height);

   --------------------
   -- Set_Background --
   --------------------

   procedure Set_Background (R, G, B : Byte) is
   begin
      LTDC_Periph.BCCR.BC :=
        UInt24 (R * 2 ** 16) or UInt24 (G * 2 ** 8) or UInt24 (B);
   end Set_Background;

   ---------------
   -- Set_Pixel --
   ---------------

   procedure Set_Pixel
     (Layer : LCD_Layer;
      X     : Natural;
      Y     : Natural;
      Value : Word)
   is
      function To_FB_Access is new Ada.Unchecked_Conversion
        (System.Address, Frame_Buffer_Int_Access);
      Buff : constant Frame_Buffer_Int_Access :=
               To_FB_Access (Frame_Buffer_Array (Layer));
   begin
      if Y >= Pixel_Height
        or else X >= Pixel_Width
      then
         return;
      end if;

      if not Swap_X_Y then
         Buff.Arr32 (Y, X) := Value;
      else
         Buff.SwArr32 (X, Y) := Value;
      end if;
   end Set_Pixel;

   ---------------
   -- Set_Pixel --
   ---------------

   procedure Set_Pixel
     (Layer : LCD_Layer;
      X     : Natural;
      Y     : Natural;
      Value : UInt24)
   is
      function To_FB_Access is new Ada.Unchecked_Conversion
        (System.Address, Frame_Buffer_Int_Access);
      Buff : constant Frame_Buffer_Int_Access :=
               To_FB_Access (Frame_Buffer_Array (Layer));
   begin
      if Y >= Pixel_Height
        or else X >= Pixel_Width
      then
         return;
      end if;

      if not Swap_X_Y then
         --  Red:
         Buff.Arr24 (Y, (X * 3) + 2) := Byte (Value and 16#FF#);
         --  Green:
         Buff.Arr24 (Y, (X * 3) + 1) := Byte ((Value and 16#FF00#) / (2 ** 8));
         --  Blue:
         Buff.Arr24 (Y, (X * 3) + 0) := Byte ((Value and 16#FF0000#) / (2 ** 16));
      else
         --  Red:
         Buff.SwArr24 (X, (Y * 3) + 2) := Byte (Value and 16#FF#);
         --  Green:
         Buff.SwArr24 (X, (Y * 3) + 1) := Byte ((Value and 16#FF00#) / (2 ** 8));
         --  Blue:
         Buff.SwArr24 (X, (Y * 3) + 0) := Byte ((Value and 16#FF0000#) / (2 ** 16));
      end if;
   end Set_Pixel;

   ---------------
   -- Set_Pixel --
   ---------------

   procedure Set_Pixel
     (Layer : LCD_Layer;
      X     : Natural;
      Y     : Natural;
      Value : Half_Word)
   is
      function To_FB_Access is new Ada.Unchecked_Conversion
        (System.Address, Frame_Buffer_Int_Access);
      Buff : constant Frame_Buffer_Int_Access :=
               To_FB_Access (Frame_Buffer_Array (Layer));
   begin
      if Y >= Pixel_Height
        or else X >= Pixel_Width
      then
         return;
      end if;

      if not Swap_X_Y then
         Buff.Arr16 (Y, X) := Value;
      else
         Buff.SwArr16 (X, Y) := Value;
      end if;
   end Set_Pixel;

   -----------------
   -- Pixel_Value --
   -----------------

   function Pixel_Value
     (Layer : LCD_Layer;
      X     : Natural;
      Y     : Natural)
      return Word
   is
      function To_FB_Access is new Ada.Unchecked_Conversion
        (System.Address, Frame_Buffer_Int_Access);
      Buff : constant Frame_Buffer_Int_Access :=
               To_FB_Access (Frame_Buffer_Array (Layer));
   begin
      if not Swap_X_Y then
         return Buff.Arr32 (Y, X);
      else
         return Buff.SwArr32 (X, Y);
      end if;
   end Pixel_Value;

   -----------------
   -- Pixel_Value --
   -----------------

   function Pixel_Value
     (Layer : LCD_Layer;
      X     : Natural;
      Y     : Natural)
      return UInt24
   is
      function To_FB_Access is new Ada.Unchecked_Conversion
        (System.Address, Frame_Buffer_Int_Access);
      Buff : constant Frame_Buffer_Int_Access :=
               To_FB_Access (Frame_Buffer_Array (Layer));
      Ret : UInt24;
   begin
      if not Swap_X_Y then
         Ret := UInt24 (Buff.Arr24 (Y, X * 3 + 2)) or
           UInt24 (Buff.Arr24 (Y, X * 3 + 1)) * 2 ** 8 or
           UInt24 (Buff.Arr24 (Y, X * 3 + 0)) * 2 ** 16;
      else
         Ret := UInt24 (Buff.SwArr24 (X, Y * 3 + 2)) or
           UInt24 (Buff.SwArr24 (X, Y * 3 + 1)) * 2 ** 8 or
           UInt24 (Buff.SwArr24 (X, Y * 3 + 0)) * 2 ** 16;
      end if;

      return Ret;
   end Pixel_Value;

   -----------------
   -- Pixel_Value --
   -----------------

   function Pixel_Value
     (Layer : LCD_Layer;
      X     : Natural;
      Y     : Natural)
      return Half_Word
   is
      function To_FB_Access is new Ada.Unchecked_Conversion
        (System.Address, Frame_Buffer_Int_Access);
      Buff : constant Frame_Buffer_Int_Access :=
               To_FB_Access (Frame_Buffer_Array (Layer));
   begin
      if not Swap_X_Y then
         return Buff.Arr16 (Y, X);
      else
         return Buff.SwArr16 (X, Y);
      end if;
   end Pixel_Value;

end STM32.LTDC;

------------------------------------------------------------------------------
--                                                                          --
--                    Copyright (C) 2015, 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    stm32f429i_discovery_lcd.c                                    --
--   @author  MCD Application Team                                          --
--   @version V1.1.0                                                        --
--   @date    19-June-2014                                                  --
--   @brief   This file includes the LTDC driver to control LCD display.    --         --
--                                                                          --
--   COPYRIGHT(c) 2014 STMicroelectronics                                   --
------------------------------------------------------------------------------

with Ada.Unchecked_Conversion;
with Ada.Real_Time;  use Ada.Real_Time;

with STM32_SVD.LTDC; use STM32_SVD.LTDC;
with STM32_SVD.RCC;  use STM32_SVD.RCC;

with STM32.SDRAM;    use STM32.SDRAM;

package body STM32.LTDC is

   Frame_Buffer_Array : array (LCD_Layer) of Frame_Buffer_Access;
   Current_Pixel_Fmt  : Pixel_Format := Pixel_Fmt_ARGB1555;
   Swap_X_Y           : Boolean := False;

   subtype LCD_Height_Range is Natural range 0 .. LCD_Height - 1;
   subtype LCD_Width_Range is Natural range 0 .. LCD_Width - 1;

   type FB32 is array (LCD_Height_Range, LCD_Width_Range) of Word
     with Component_Size => 32, Volatile;
   type FB24 is array (LCD_Height_Range, 0 .. LCD_Height * 3 - 1) of Byte
     with Component_Size => 8, Volatile;
   type FB16 is array (LCD_Height_Range, LCD_Width_Range) of Short
     with Component_Size => 16, Volatile;

   function Pixel_Size (Fmt : Pixel_Format) return Positive;

   ----------
   -- Init --
   ----------

   package Init is
      BF1_Constant_Alpha : constant := 2#100#;
      BF2_Constant_Alpha : constant := 2#101#;
      BF1_Pixel_Alpha    : constant := 2#110#;
      BF2_Pixel_Alpha    : constant := 2#111#;

      procedure Reload_Config (Immediate : Boolean);

      procedure Set_Layer_CFBA
        (Layer : LCD_Layer;
         FBA   : Frame_Buffer_Access);
      --  Sets the frame buffer of the specified layer

      function Get_Layer_CFBA
        (Layer : LCD_Layer) return Frame_Buffer_Access;
      --  Gets the frame buffer of the specified layer

      procedure LTDC_Init;

      procedure Layer_Init
        (Layer    : LCD_Layer;
         Config   : Pixel_Format;
         BF1, BF2 : UInt3);

      procedure Set_Layer_State
        (Layer : LCD_Layer;
         State : Boolean);
      --  Enables/Disables the specified layer

   end Init;

   package body Init is separate;

   -------------------
   -- Reload_Config --
   -------------------

   procedure Reload_Config
     (Immediate : Boolean := True)
      renames Init.Reload_Config;

   ---------------------
   -- Set_Layer_State --
   ---------------------

   procedure Set_Layer_State
     (Layer : LCD_Layer;
      State : Layer_State)
   is
   begin
      Init.Set_Layer_State (Layer, State = Enabled);
   end Set_Layer_State;

   ----------------
   -- Initialize --
   ----------------

   procedure Initialize (Pixel_Fmt : Pixel_Format := Pixel_Fmt_ARGB1555)
   is
      FB_Size : constant Word :=
                  Word
                    (LCD_Width * LCD_Height * Pixel_Size (Pixel_Fmt));
   begin
      if Initialized then
         return;
      end if;

      Pre_LTDC_Initialize;

      delay until Clock + Milliseconds (200);

      Init.LTDC_Init;
      STM32.SDRAM.Initialize;

      Current_Pixel_Fmt := Pixel_Fmt;

      Frame_Buffer_Array (Layer1) := STM32.SDRAM.Reserve (FB_Size);

      Init.Layer_Init
        (Layer1, Pixel_Fmt,
         Init.BF1_Constant_Alpha,
         Init.BF2_Constant_Alpha);
      Init.Layer_Init
        (Layer2, Pixel_Fmt,
         Init.BF1_Pixel_Alpha,
         Init.BF2_Pixel_Alpha);

      Init.Set_Layer_State (Layer1, True);
      Init.Set_Layer_State (Layer2, False);

      Reload_Config (True);

      --  enable Dither
      LTDC_Periph.GCR.DEN := 1;

      Reload_Config (True);

      Post_LTDC_Initialize;
   end Initialize;

   -----------------
   -- Initialized --
   -----------------

   function Initialized return Boolean is
   begin
      return Frame_Buffer_Array (Layer1) /= Null_Address;
   end Initialized;

   ----------------
   -- Pixel_Size --
   ----------------

   function Pixel_Size (Fmt : Pixel_Format) return Positive is
     (case Fmt is
         when Pixel_Fmt_ARGB8888 => 4,
         when Pixel_Fmt_RGB888   => 3,
         when Pixel_Fmt_RGB565 | Pixel_Fmt_ARGB1555 | Pixel_Fmt_ARGB4444 => 2);

   -------------------
   -- Get_Pixel_Fmt --
   -------------------

   function Get_Pixel_Fmt return Pixel_Format is
      (Current_Pixel_Fmt);

   --------------------------
   -- Current_Frame_Buffer --
   --------------------------

   function Current_Frame_Buffer
     (Layer : LCD_Layer)
      return Frame_Buffer_Access
     renames Init.Get_Layer_CFBA;

   ----------------------
   -- Set_Frame_Buffer --
   ----------------------

   procedure Set_Frame_Buffer
     (Layer : LCD_Layer; Addr : Frame_Buffer_Access)
      renames Init.Set_Layer_CFBA;

   ---------------------
   -- Set_Orientation --
   ---------------------

   procedure Set_Orientation (Orientation : Orientation_Mode)
   is
   begin
      case Orientation is
         when Portrait =>
            Swap_X_Y := LCD_Width > LCD_Height;
         when Landscape =>
            Swap_X_Y := LCD_Height > LCD_Width;
      end case;
   end Set_Orientation;

   ---------------------
   -- Get_Orientation --
   ---------------------

   function Get_Orientation return Orientation_Mode
   is
   begin
      return (if Pixel_Width > Pixel_Height then Landscape else Portrait);
   end Get_Orientation;

   ------------
   -- SwapXY --
   ------------

   function SwapXY return Boolean
   is (Swap_X_Y);

   -----------------
   -- Pixel_Width --
   -----------------

   function Pixel_Width return Natural
   is (if Swap_X_Y then LCD_Height else LCD_Width);

   ------------------
   -- Pixel_Height --
   ------------------

   function Pixel_Height return Natural
   is (if Swap_X_Y then LCD_Width else LCD_Height);

   --------------------
   -- Set_Background --
   --------------------

   procedure Set_Background (R, G, B : Byte) is
   begin
      LTDC_Periph.BCCR.BC :=
        UInt24 (R * 2 ** 16) or UInt24 (G * 2 ** 8) or UInt24 (B);
   end Set_Background;

   procedure Convert (X, Y : Natural;
                      Ok   : out Boolean;
                      X0   : out LCD_Width_Range;
                      Y0   : out LCD_Height_Range)
   is
   begin
      if Y >= Pixel_Height or else X >= Pixel_Width then
         Ok := False;
      else
         Ok := True;
         if not Swap_X_Y then
            Y0 := Y;
            X0 := X;
         else
            Y0 := LCD_Height - 1 - X;
            X0 := Y;
         end if;
      end if;
   end Convert;

   ---------------
   -- Set_Pixel --
   ---------------

   procedure Set_Pixel
     (Layer : LCD_Layer;
      X     : Natural;
      Y     : Natural;
      Value : Word)
   is
      FB : FB32 with Import, Address => Frame_Buffer_Array (Layer);
      X0 : LCD_Height_Range;
      Y0 : LCD_Width_Range;
      Ok : Boolean;
   begin
      Convert (X, Y, Ok, X0, Y0);
      if Ok then
         FB (Y0, X0) := Value;
      end if;
   end Set_Pixel;

   ---------------
   -- Set_Pixel --
   ---------------

   procedure Set_Pixel
     (Layer : LCD_Layer;
      X     : Natural;
      Y     : Natural;
      Value : UInt24)
   is
      FB : FB24 with Import, Address => Frame_Buffer_Array (Layer);
      X0 : LCD_Height_Range;
      Y0 : LCD_Width_Range;
      Ok : Boolean;
   begin
      Convert (X, Y, Ok, X0, Y0);
      if Ok then
         --  Red:
         FB (Y0, (X0 * 3) + 2) := Byte (Value and 16#FF#);
         --  Green:
         FB (Y0, (X0 * 3) + 1) := Byte ((Value and 16#FF00#) / (2 ** 8));
         --  Blue:
         FB (Y0, (X0 * 3) + 0) := Byte ((Value and 16#FF0000#) / (2 ** 16));
      end if;
   end Set_Pixel;

   ---------------
   -- Set_Pixel --
   ---------------

   procedure Set_Pixel
     (Layer : LCD_Layer;
      X     : Natural;
      Y     : Natural;
      Value : Half_Word)
   is
      FB : FB16 with Import, Address => Frame_Buffer_Array (Layer);
      X0 : LCD_Height_Range;
      Y0 : LCD_Width_Range;
      Ok : Boolean;
   begin
      Convert (X, Y, Ok, X0, Y0);
      if Ok then
         FB (Y0, X0) := Value;
      end if;
   end Set_Pixel;

   -----------------
   -- Pixel_Value --
   -----------------

   function Pixel_Value
     (Layer : LCD_Layer;
      X     : Natural;
      Y     : Natural)
      return Word
   is
      FB : FB32 with Import, Address => Frame_Buffer_Array (Layer);
      X0 : LCD_Height_Range;
      Y0 : LCD_Width_Range;
      Ok : Boolean;
   begin
      Convert (X, Y, Ok, X0, Y0);
      if Ok then
         return FB (Y0, X0);
      else
         return 0;
      end if;
   end Pixel_Value;

   -----------------
   -- Pixel_Value --
   -----------------

   function Pixel_Value
     (Layer : LCD_Layer;
      X     : Natural;
      Y     : Natural)
      return UInt24
   is
      FB : FB24 with Import, Address => Frame_Buffer_Array (Layer);
      X0 : LCD_Height_Range;
      Y0 : LCD_Width_Range;
      Ok : Boolean;
   begin
      Convert (X, Y, Ok, X0, Y0);
      if Ok then
         return UInt24 (FB (Y0, X0 * 3 + 2)) or
           UInt24 (FB (Y0, X0 * 3 + 1)) * 2 ** 8 or
           UInt24 (FB (Y0, X0 * 3 + 0)) * 2 ** 16;
      else
         return 0;
      end if;
   end Pixel_Value;

   -----------------
   -- Pixel_Value --
   -----------------

   function Pixel_Value
     (Layer : LCD_Layer;
      X     : Natural;
      Y     : Natural)
      return Half_Word
   is
      FB : FB16 with Import, Address => Frame_Buffer_Array (Layer);
      X0 : LCD_Height_Range;
      Y0 : LCD_Width_Range;
      Ok : Boolean;
   begin
      Convert (X, Y, Ok, X0, Y0);
      if Ok then
         return FB (Y0, X0);
      else
         return 0;
      end if;
   end Pixel_Value;

end STM32.LTDC;

fix soft x-y swap, factorize.

stm32-ltdc: fix soft x-y swap, factorize.


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

with Util.Tests;
with Util.Log.Loggers;

with AWA.Applications;
with AWA.Tests;
with AWA.Users.Modules;
with ADO.Sessions;
with ADO.SQL;
package body AWA.Tests.Helpers.Users is

   use AWA.Users.Services;

   use Util.Log;

   Log : constant Loggers.Logger := Loggers.Create ("AWA.Tests.Helpers.Users");

   --  ------------------------------
   --  Initialize the service context.
   --  ------------------------------
   procedure Initialize (Principal : in out Test_User) is
   begin
      --  Setup the service context.
      Principal.Context.Set_Context (AWA.Tests.Get_Application, null);

      if Principal.Manager = null then
         Principal.Manager := AWA.Users.Modules.Get_User_Manager;
         if Principal.Manager = null then
            Log.Error ("There is no User_Manager in the application.");
         end if;
      end if;
   end Initialize;

   --  ------------------------------
   --  Create a test user associated with the given email address.
   --  Get an open session for that user.  If the user already exists, no error is reported.
   --  ------------------------------
   procedure Create_User (Principal : in out Test_User;
                          Email     : in String) is
      DB    : ADO.Sessions.Session;
      Query : ADO.SQL.Query;
      Found : Boolean;
      Key   : AWA.Users.Models.Access_Key_Ref;
   begin
      Initialize (Principal);

      DB := Principal.Manager.Get_Session;

      --  Find the user
      Query.Set_Join ("inner join email e on e.user_id = o.id");
      Query.Set_Filter ("e.email = ?");
      Query.Bind_Param (1, Email);
      Principal.User.Find (DB, Query, Found);
      if not Found then
         Principal.User.Set_First_Name ("Joe");
         Principal.User.Set_Last_Name ("Pot");
         Principal.User.Set_Password ("admin");
         Principal.Email.Set_Email (Email);
         Principal.Manager.Create_User (Principal.User, Principal.Email);

         Find_Access_Key (Principal, Email, Key);

         --  Run the verification and get the user and its session
         Principal.Manager.Verify_User (Key.Get_Access_Key, "192.168.1.1",
                                        Principal.Principal);
      else
         Principal.Manager.Authenticate (Email     => Email,
                                         Password  => "admin",
                                         IpAddr    => "192.168.1.1",
                                         Principal => Principal.Principal);
      end if;
      Principal.User    := Principal.Principal.Get_User;
      Principal.Session := Principal.Principal.Get_Session;
   end Create_User;

   --  ------------------------------
   --  Create a test user for a new test and get an open session.
   --  ------------------------------
   procedure Create_User (Principal : in out Test_User) is
      Key     : AWA.Users.Models.Access_Key_Ref;
      Email   : constant String := "Joe-" & Util.Tests.Get_Uuid & "@gmail.com";
   begin
      Initialize (Principal);
      Principal.User.Set_First_Name ("Joe");
      Principal.User.Set_Last_Name ("Pot");
      Principal.User.Set_Password ("admin");
      Principal.Email.Set_Email (Email);
      Principal.Manager.Create_User (Principal.User, Principal.Email);

      Find_Access_Key (Principal, Email, Key);

      --  Run the verification and get the user and its session
      Principal.Manager.Verify_User (Key.Get_Access_Key, "192.168.1.1",
                                     Principal.Principal);
      Principal.User    := Principal.Principal.Get_User;
      Principal.Session := Principal.Principal.Get_Session;
   end Create_User;

   --  ------------------------------
   --  Find the access key associated with a user (if any).
   --  ------------------------------
   procedure Find_Access_Key (Principal : in out Test_User;
                              Email     : in String;
                              Key       : in out AWA.Users.Models.Access_Key_Ref) is
      DB    : ADO.Sessions.Session;
      Query : ADO.SQL.Query;
      Found : Boolean;
   begin
      Initialize (Principal);

      DB := Principal.Manager.Get_Session;

      --  Find the access key
      Query.Set_Join ("inner join email e on e.user_id = o.user_id");
      Query.Set_Filter ("e.email = ?");
      Query.Bind_Param (1, Email);
      Key.Find (DB, Query, Found);
      if not Found then
         Log.Error ("Cannot find access key for email {0}", Email);
      end if;
   end Find_Access_Key;

   --  ------------------------------
   --  Login a user and create a session
   --  ------------------------------
   procedure Login (Principal : in out Test_User) is
   begin
      Initialize (Principal);
      Principal.Manager.Authenticate (Email     => Principal.Email.Get_Email,
                                      Password  => "admin",
                                      IpAddr    => "192.168.1.1",
                                      Principal => Principal.Principal);
      Principal.User    := Principal.Principal.Get_User;
      Principal.Session := Principal.Principal.Get_Session;
   end Login;

   --  ------------------------------
   --  Logout the user and closes the current session.
   --  ------------------------------
   procedure Logout (Principal : in out Test_User) is
   begin
      Initialize (Principal);
      Principal.Manager.Close_Session (Principal.Session.Get_Id, True);
   end Logout;

   --  Simulate a user login in the given service context.
   procedure Login (Context : in out AWA.Services.Contexts.Service_Context;
                    Sec_Context : in out Security.Contexts.Security_Context;
                    Email   : in String) is
      User      : Test_User;
      Principal : AWA.Users.Principals.Principal_Access;
      App       : constant AWA.Applications.Application_Access := AWA.Tests.Get_Application;
   begin
      AWA.Tests.Set_Application_Context;
      Create_User (User, Email);
      Principal := AWA.Users.Principals.Create (User.User, User.Session);
      Context.Set_Context (App, Principal);
      Sec_Context.Set_Context (Manager   => App.Get_Permission_Manager,
                               Principal => Principal.all'Access);
   end Login;

   overriding
   procedure Finalize (Principal : in out Test_User) is
      procedure Free is
         new Ada.Unchecked_Deallocation (Object => AWA.Users.Principals.Principal'Class,
                                         Name   => AWA.Users.Principals.Principal_Access);
   begin
      Free (Principal.Principal);
   end Finalize;

end AWA.Tests.Helpers.Users;

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

with Util.Tests;
with Util.Log.Loggers;

with AWA.Applications;
with AWA.Tests;
with AWA.Users.Modules;
with ADO.Sessions;
with ADO.SQL;
package body AWA.Tests.Helpers.Users is

   use AWA.Users.Services;

   use Util.Log;

   Log : constant Loggers.Logger := Loggers.Create ("AWA.Tests.Helpers.Users");

   --  ------------------------------
   --  Initialize the service context.
   --  ------------------------------
   procedure Initialize (Principal : in out Test_User) is
   begin
      --  Setup the service context.
      Principal.Context.Set_Context (AWA.Tests.Get_Application, null);

      if Principal.Manager = null then
         Principal.Manager := AWA.Users.Modules.Get_User_Manager;
         if Principal.Manager = null then
            Log.Error ("There is no User_Manager in the application.");
         end if;
      end if;
   end Initialize;

   --  ------------------------------
   --  Create a test user associated with the given email address.
   --  Get an open session for that user.  If the user already exists, no error is reported.
   --  ------------------------------
   procedure Create_User (Principal : in out Test_User;
                          Email     : in String) is
      DB    : ADO.Sessions.Session;
      Query : ADO.SQL.Query;
      Found : Boolean;
      Key   : AWA.Users.Models.Access_Key_Ref;
   begin
      Initialize (Principal);

      DB := Principal.Manager.Get_Session;

      --  Find the user
      Query.Set_Join ("inner join email e on e.user_id = o.id");
      Query.Set_Filter ("e.email = ?");
      Query.Bind_Param (1, Email);
      Principal.User.Find (DB, Query, Found);
      if not Found then
         Principal.User.Set_First_Name ("Joe");
         Principal.User.Set_Last_Name ("Pot");
         Principal.User.Set_Password ("admin");
         Principal.Email.Set_Email (Email);
         Principal.Manager.Create_User (Principal.User, Principal.Email);

         Find_Access_Key (Principal, Email, Key);

         --  Run the verification and get the user and its session
         Principal.Manager.Verify_User (Key.Get_Access_Key, "192.168.1.1",
                                        Principal.Principal);
      else
         Principal.Manager.Authenticate (Email     => Email,
                                         Password  => "admin",
                                         IpAddr    => "192.168.1.1",
                                         Principal => Principal.Principal);
      end if;
      Principal.User    := Principal.Principal.Get_User;
      Principal.Session := Principal.Principal.Get_Session;
   end Create_User;

   --  ------------------------------
   --  Create a test user for a new test and get an open session.
   --  ------------------------------
   procedure Create_User (Principal : in out Test_User) is
      Key     : AWA.Users.Models.Access_Key_Ref;
      Email   : constant String := "Joe-" & Util.Tests.Get_Uuid & "@gmail.com";
   begin
      Initialize (Principal);
      Principal.User.Set_First_Name ("Joe");
      Principal.User.Set_Last_Name ("Pot");
      Principal.User.Set_Password ("admin");
      Principal.Email.Set_Email (Email);
      Principal.Manager.Create_User (Principal.User, Principal.Email);

      Find_Access_Key (Principal, Email, Key);

      --  Run the verification and get the user and its session
      Principal.Manager.Verify_User (Key.Get_Access_Key, "192.168.1.1",
                                     Principal.Principal);
      Principal.User    := Principal.Principal.Get_User;
      Principal.Session := Principal.Principal.Get_Session;
   end Create_User;

   --  ------------------------------
   --  Find the access key associated with a user (if any).
   --  ------------------------------
   procedure Find_Access_Key (Principal : in out Test_User;
                              Email     : in String;
                              Key       : in out AWA.Users.Models.Access_Key_Ref) is
      DB    : ADO.Sessions.Session;
      Query : ADO.SQL.Query;
      Found : Boolean;
   begin
      Initialize (Principal);

      DB := Principal.Manager.Get_Session;

      --  Find the access key
      Query.Set_Join ("inner join email e on e.user_id = o.user_id");
      Query.Set_Filter ("e.email = ?");
      Query.Bind_Param (1, Email);
      Key.Find (DB, Query, Found);
      if not Found then
         Log.Error ("Cannot find access key for email {0}", Email);
      end if;
   end Find_Access_Key;

   --  ------------------------------
   --  Login a user and create a session
   --  ------------------------------
   procedure Login (Principal : in out Test_User) is
   begin
      Initialize (Principal);
      Principal.Manager.Authenticate (Email     => Principal.Email.Get_Email,
                                      Password  => "admin",
                                      IpAddr    => "192.168.1.1",
                                      Principal => Principal.Principal);
      Principal.User    := Principal.Principal.Get_User;
      Principal.Session := Principal.Principal.Get_Session;
   end Login;

   --  ------------------------------
   --  Logout the user and closes the current session.
   --  ------------------------------
   procedure Logout (Principal : in out Test_User) is
   begin
      Initialize (Principal);
      Principal.Manager.Close_Session (Principal.Session.Get_Id, True);
   end Logout;

   --  Simulate a user login in the given service context.
   procedure Login (Context : in out AWA.Services.Contexts.Service_Context;
                    Sec_Context : in out Security.Contexts.Security_Context;
                    Email   : in String) is
      User      : Test_User;
      Principal : AWA.Users.Principals.Principal_Access;
      App       : constant AWA.Applications.Application_Access := AWA.Tests.Get_Application;
   begin
      AWA.Tests.Set_Application_Context;
      Create_User (User, Email);
      Principal := AWA.Users.Principals.Create (User.User, User.Session);
      Context.Set_Context (App, Principal);
      Sec_Context.Set_Context (Manager   => App.Get_Security_Manager,
                               Principal => Principal.all'Access);
   end Login;

   overriding
   procedure Finalize (Principal : in out Test_User) is
      procedure Free is
         new Ada.Unchecked_Deallocation (Object => AWA.Users.Principals.Principal'Class,
                                         Name   => AWA.Users.Principals.Principal_Access);
   begin
      Free (Principal.Principal);
   end Finalize;

end AWA.Tests.Helpers.Users;

Fix compilation

Fix compilation


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

with Ada.Text_IO;
with Ada.Calendar;
with Ada.Unchecked_Deallocation;

with Util.Tests;
with Util.Test_Caller;
package body ASF.Contexts.Writer.Tests is

   use Util.Tests;

   procedure Free_Writer is
     new Ada.Unchecked_Deallocation (Object => Test_Writer'Class,
                                     Name   => Test_Writer_Access);

   procedure Initialize (Stream       : in out Test_Writer;
                         Content_Type : in String;
                         Encoding     : in String;
                         Size         : in Natural) is
      Output : ASF.Streams.Print_Stream;
   begin
      Stream.Content.Initialize (Size => Size);
      Output.Initialize (Stream.Content'Unchecked_Access);
      Stream.Initialize (Content_Type, Encoding, Output);
   end Initialize;

   overriding
   procedure Write (Stream : in out Test_Writer;
                    Buffer : in Ada.Streams.Stream_Element_Array) is
   begin
      for I in Buffer'Range loop
         Append (Stream.Response, Character'Val (Buffer (I)));
      end loop;
   end Write;

   overriding
   procedure Flush (Stream : in out Test_Writer) is
   begin
      Response_Writer (Stream).Flush;
      Stream.Content.Read (Into => Stream.Response);
   end Flush;

   --  Set up performed before each test case
   overriding
   procedure Set_Up (T : in out Test) is
   begin
      T.Writer := new Test_Writer;
      --  use a small buffer to test the flush
      T.Writer.Initialize ("text/xml", "UTF-8", 1024);
   end Set_Up;

   --  Tear down performed after each test case
   overriding
   procedure Tear_Down (T : in out Test) is
   begin
      Free_Writer (T.Writer);
   end Tear_Down;

   --  Test the Start/Write/End_Element methods
   procedure Test_Write_Element (T : in out Test) is
   begin
      T.Writer.Start_Element ("p");
      T.Writer.Start_Element ("b");
      T.Writer.Write_Element ("i", "italic within a bold");
      T.Writer.End_Element ("b");
      T.Writer.End_Element ("p");
      T.Writer.Flush;

      Assert_Equals (T, "
italic within a bold
",
                     T.Writer.Response);

      T.Writer.Response := To_Unbounded_String ("");
      T.Writer.Start_Element ("div");
      T.Writer.Write_Attribute ("title", "A ""S&'%^&<>");
      T.Writer.Write_Attribute ("id", "23");
      T.Writer.End_Element ("div");
      T.Writer.Flush;

      Assert_Equals (T, "

",
                     T.Writer.Response);
   end Test_Write_Element;

   --  Test the Write_Char/Text methods
   procedure Test_Write_Text (T : in out Test) is
      use Ada.Calendar;
      Start : Ada.Calendar.Time;
      D     : Duration;
   begin
      Start := Ada.Calendar.Clock;
      T.Writer.Start_Element ("p");
      T.Writer.Write_Char ('<');
      T.Writer.Write_Char ('>');
      T.Writer.Write_Char ('~');
      T.Writer.Start_Element ("i");
      T.Writer.Write_Text ("""A' <>&");
      T.Writer.End_Element ("i");
      T.Writer.End_Element ("p");
      T.Writer.Flush;
      D := Ada.Calendar.Clock - Start;
      Ada.Text_IO.Put_Line ("Write text: " & Duration'Image (D));

      Assert_Equals (T, "
<>~""A' <>&
",
                     T.Writer.Response);
   end Test_Write_Text;

   package Caller is new Util.Test_Caller (Test, "Contexts.Writer");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is

   begin
      --  To document what is tested, register the test methods for each
      --  operation that is tested.
      Caller.Add_Test (Suite, "Test ASF.Contexts.Writer.Start_Element",
                       Test_Write_Element'Access);
      Caller.Add_Test (Suite, "Test ASF.Contexts.Writer.End_Element",
                       Test_Write_Element'Access);

      Caller.Add_Test (Suite, "Test ASF.Contexts.Writer.Write_Element",
                       Test_Write_Element'Access);

      Caller.Add_Test (Suite, "Test ASF.Contexts.Writer.Write_Attribute",
                       Test_Write_Element'Access);

      Caller.Add_Test (Suite, "Test ASF.Contexts.Writer.Write_Text",
                       Test_Write_Text'Access);

      Caller.Add_Test (Suite, "Test ASF.Contexts.Writer.Write_Char",
                       Test_Write_Text'Access);
   end Add_Tests;

end ASF.Contexts.Writer.Tests;

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

with Ada.Text_IO;
with Ada.Calendar;
with Ada.Unchecked_Deallocation;

with Util.Test_Caller;
package body ASF.Contexts.Writer.Tests is

   use Util.Tests;

   procedure Free_Writer is
     new Ada.Unchecked_Deallocation (Object => Test_Writer'Class,
                                     Name   => Test_Writer_Access);

   procedure Initialize (Stream       : in out Test_Writer;
                         Content_Type : in String;
                         Encoding     : in String;
                         Size         : in Natural) is
      Output : ASF.Streams.Print_Stream;
   begin
      Stream.Content.Initialize (Size => Size);
      Output.Initialize (Stream.Content'Unchecked_Access);
      Stream.Initialize (Content_Type, Encoding, Output);
   end Initialize;

   overriding
   procedure Write (Stream : in out Test_Writer;
                    Buffer : in Ada.Streams.Stream_Element_Array) is
   begin
      for I in Buffer'Range loop
         Append (Stream.Response, Character'Val (Buffer (I)));
      end loop;
   end Write;

   overriding
   procedure Flush (Stream : in out Test_Writer) is
   begin
      Response_Writer (Stream).Flush;
      Stream.Content.Read (Into => Stream.Response);
   end Flush;

   --  Set up performed before each test case
   overriding
   procedure Set_Up (T : in out Test) is
   begin
      T.Writer := new Test_Writer;
      --  use a small buffer to test the flush
      T.Writer.Initialize ("text/xml", "UTF-8", 1024);
   end Set_Up;

   --  Tear down performed after each test case
   overriding
   procedure Tear_Down (T : in out Test) is
   begin
      Free_Writer (T.Writer);
   end Tear_Down;

   --  Test the Start/Write/End_Element methods
   procedure Test_Write_Element (T : in out Test) is
   begin
      T.Writer.Start_Element ("p");
      T.Writer.Start_Element ("b");
      T.Writer.Write_Element ("i", "italic within a bold");
      T.Writer.End_Element ("b");
      T.Writer.End_Element ("p");
      T.Writer.Flush;

      Assert_Equals (T, "
italic within a bold
",
                     T.Writer.Response);

      T.Writer.Response := To_Unbounded_String ("");
      T.Writer.Start_Element ("div");
      T.Writer.Write_Attribute ("title", "A ""S&'%^&<>");
      T.Writer.Write_Attribute ("id", "23");
      T.Writer.End_Element ("div");
      T.Writer.Flush;

      Assert_Equals (T, "

",
                     T.Writer.Response);
   end Test_Write_Element;

   --  Test the Write_Char/Text methods
   procedure Test_Write_Text (T : in out Test) is
      use Ada.Calendar;
      Start : Ada.Calendar.Time;
      D     : Duration;
   begin
      Start := Ada.Calendar.Clock;
      T.Writer.Start_Element ("p");
      T.Writer.Write_Char ('<');
      T.Writer.Write_Char ('>');
      T.Writer.Write_Char ('~');
      T.Writer.Start_Element ("i");
      T.Writer.Write_Text ("""A' <>&");
      T.Writer.End_Element ("i");
      T.Writer.End_Element ("p");
      T.Writer.Flush;
      D := Ada.Calendar.Clock - Start;
      Ada.Text_IO.Put_Line ("Write text: " & Duration'Image (D));

      Assert_Equals (T, "
<>~""A' <>&
",
                     T.Writer.Response);
   end Test_Write_Text;

   package Caller is new Util.Test_Caller (Test, "Contexts.Writer");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is

   begin
      --  To document what is tested, register the test methods for each
      --  operation that is tested.
      Caller.Add_Test (Suite, "Test ASF.Contexts.Writer.Start_Element",
                       Test_Write_Element'Access);
      Caller.Add_Test (Suite, "Test ASF.Contexts.Writer.End_Element",
                       Test_Write_Element'Access);

      Caller.Add_Test (Suite, "Test ASF.Contexts.Writer.Write_Element",
                       Test_Write_Element'Access);

      Caller.Add_Test (Suite, "Test ASF.Contexts.Writer.Write_Attribute",
                       Test_Write_Element'Access);

      Caller.Add_Test (Suite, "Test ASF.Contexts.Writer.Write_Text",
                       Test_Write_Text'Access);

      Caller.Add_Test (Suite, "Test ASF.Contexts.Writer.Write_Char",
                       Test_Write_Text'Access);
   end Add_Tests;

end ASF.Contexts.Writer.Tests;

Fix compilation warning

Fix compilation warning


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

with GNAT.Sockets;

with MAT.Types;
with MAT.Memory.Targets;
with MAT.Symbols.Targets;
with MAT.Events.Targets;
with MAT.Readers.Streams.Sockets;
with MAT.Readers;
with MAT.Consoles;
package MAT.Targets is

   --  Exception raised if some option is invalid.
   Usage_Error : exception;

   --  The options that can be configured through the command line.
   type Options_Type is record
      --  Enable and enter in the interactive TTY console mode.
      Interactive  : Boolean := True;

      --  Try to load the symbol file automatically when a new process is recieved.
      Load_Symbols : Boolean := True;

      --  Enable the graphical mode (when available).
      Graphical    : Boolean := False;

      --  Define the server listening address.
      Address      : GNAT.Sockets.Sock_Addr_Type := (Port => 4096, others => <>);
   end record;

   type Target_Process_Type is tagged limited record
      Pid     : MAT.Types.Target_Process_Ref;
      Path    : Ada.Strings.Unbounded.Unbounded_String;
      Memory  : MAT.Memory.Targets.Target_Memory;
      Symbols : MAT.Symbols.Targets.Target_Symbols_Ref;
      Events  : MAT.Events.Targets.Target_Events_Access;
      Console : MAT.Consoles.Console_Access;
   end record;
   type Target_Process_Type_Access is access all Target_Process_Type'Class;

   type Target_Type is new Ada.Finalization.Limited_Controlled with private;

   type Target_Type_Access is access all Target_Type'Class;

   --  Get the console instance.
   function Console (Target : in Target_Type) return MAT.Consoles.Console_Access;

   --  Set the console instance.
   procedure Console (Target  : in out Target_Type;
                      Console : in MAT.Consoles.Console_Access);

   --  Get the current process instance.
   function Process (Target : in Target_Type) return Target_Process_Type_Access;

   --  Initialize the target object to manage the memory slots, the stack frames
   --  and setup the reader to analyze the memory and other events.
   procedure Initialize (Target : in out Target_Type;
                         Reader : in out MAT.Readers.Manager_Base'Class);

   --  Create a process instance to hold and keep track of memory and other information about
   --  the given process ID.
   procedure Create_Process (Target  : in out Target_Type;
                             Pid     : in MAT.Types.Target_Process_Ref;
                             Path    : in Ada.Strings.Unbounded.Unbounded_String;
                             Process : out Target_Process_Type_Access);

   --  Find the process instance from the process ID.
   function Find_Process (Target : in Target_Type;
                          Pid    : in MAT.Types.Target_Process_Ref)
                          return Target_Process_Type_Access;

   --  Parse the command line arguments and configure the target instance.
   procedure Initialize_Options (Target  : in out Target_Type);

   --  Enter in the interactive loop reading the commands from the standard input
   --  and executing the commands.
   procedure Interactive (Target : in out MAT.Targets.Target_Type);

   --  Start the server to listen to MAT event socket streams.
   procedure Start (Target : in out Target_Type);

   --  Stop the server thread.
   procedure Stop (Target : in out Target_Type);

   --  Convert the string to a socket address.  The string can have two forms:
   --     port
   --     host:port
   function To_Sock_Addr_Type (Param : in String) return GNAT.Sockets.Sock_Addr_Type;

   --  Print the application usage.
   procedure Usage;

private

   --  Define a map of <tt>Target_Process_Type_Access</tt> keyed by the process Id.
   --  This map allows to retrieve the information about a process.
   use type MAT.Types.Target_Process_Ref;
   package Process_Maps is
     new Ada.Containers.Ordered_Maps (Key_Type     => MAT.Types.Target_Process_Ref,
                                      Element_Type => Target_Process_Type_Access);

   subtype Process_Map is Process_Maps.Map;
   subtype Process_Cursor is Process_Maps.Cursor;

   type Target_Type is new Ada.Finalization.Limited_Controlled with record
      Current   : Target_Process_Type_Access;
      Processes : Process_Map;
      Console   : MAT.Consoles.Console_Access;
      Options   : Options_Type;
      Server    : MAT.Readers.Streams.Sockets.Socket_Listener_Type;
   end record;

end MAT.Targets;

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

with GNAT.Sockets;

with MAT.Types;
with MAT.Memory.Targets;
with MAT.Symbols.Targets;
with MAT.Events.Targets;
with MAT.Readers.Streams.Sockets;
with MAT.Readers;
with MAT.Consoles;
package MAT.Targets is

   --  Exception raised if some option is invalid.
   Usage_Error : exception;

   --  The options that can be configured through the command line.
   type Options_Type is record
      --  Enable and enter in the interactive TTY console mode.
      Interactive  : Boolean := True;

      --  Try to load the symbol file automatically when a new process is recieved.
      Load_Symbols : Boolean := True;

      --  Enable the graphical mode (when available).
      Graphical    : Boolean := False;

      --  Define the server listening address.
      Address      : GNAT.Sockets.Sock_Addr_Type := (Port => 4096, others => <>);
   end record;

   type Target_Process_Type is tagged limited record
      Pid     : MAT.Types.Target_Process_Ref;
      Path    : Ada.Strings.Unbounded.Unbounded_String;
      Memory  : MAT.Memory.Targets.Target_Memory;
      Symbols : MAT.Symbols.Targets.Target_Symbols_Ref;
      Events  : MAT.Events.Targets.Target_Events_Access;
      Console : MAT.Consoles.Console_Access;
   end record;
   type Target_Process_Type_Access is access all Target_Process_Type'Class;

   type Target_Type is new Ada.Finalization.Limited_Controlled with private;

   type Target_Type_Access is access all Target_Type'Class;

   --  Get the console instance.
   function Console (Target : in Target_Type) return MAT.Consoles.Console_Access;

   --  Set the console instance.
   procedure Console (Target  : in out Target_Type;
                      Console : in MAT.Consoles.Console_Access);

   --  Get the current process instance.
   function Process (Target : in Target_Type) return Target_Process_Type_Access;

   --  Initialize the target object to manage the memory slots, the stack frames
   --  and setup the reader to analyze the memory and other events.
   procedure Initialize (Target : in out Target_Type;
                         Reader : in out MAT.Readers.Manager_Base'Class);

   --  Create a process instance to hold and keep track of memory and other information about
   --  the given process ID.
   procedure Create_Process (Target  : in out Target_Type;
                             Pid     : in MAT.Types.Target_Process_Ref;
                             Path    : in Ada.Strings.Unbounded.Unbounded_String;
                             Process : out Target_Process_Type_Access);

   --  Find the process instance from the process ID.
   function Find_Process (Target : in Target_Type;
                          Pid    : in MAT.Types.Target_Process_Ref)
                          return Target_Process_Type_Access;

   --  Iterate over the list of connected processes and execute the <tt>Process</tt> procedure.
   procedure Iterator (Target  : in Target_Type;
                       Process : access procedure (Proc : in Target_Process_Type'Class));

   --  Parse the command line arguments and configure the target instance.
   procedure Initialize_Options (Target  : in out Target_Type);

   --  Enter in the interactive loop reading the commands from the standard input
   --  and executing the commands.
   procedure Interactive (Target : in out MAT.Targets.Target_Type);

   --  Start the server to listen to MAT event socket streams.
   procedure Start (Target : in out Target_Type);

   --  Stop the server thread.
   procedure Stop (Target : in out Target_Type);

   --  Convert the string to a socket address.  The string can have two forms:
   --     port
   --     host:port
   function To_Sock_Addr_Type (Param : in String) return GNAT.Sockets.Sock_Addr_Type;

   --  Print the application usage.
   procedure Usage;

private

   --  Define a map of <tt>Target_Process_Type_Access</tt> keyed by the process Id.
   --  This map allows to retrieve the information about a process.
   use type MAT.Types.Target_Process_Ref;
   package Process_Maps is
     new Ada.Containers.Ordered_Maps (Key_Type     => MAT.Types.Target_Process_Ref,
                                      Element_Type => Target_Process_Type_Access);

   subtype Process_Map is Process_Maps.Map;
   subtype Process_Cursor is Process_Maps.Cursor;

   type Target_Type is new Ada.Finalization.Limited_Controlled with record
      Current   : Target_Process_Type_Access;
      Processes : Process_Map;
      Console   : MAT.Consoles.Console_Access;
      Options   : Options_Type;
      Server    : MAT.Readers.Streams.Sockets.Socket_Listener_Type;
   end record;

end MAT.Targets;

Declare the Iterator procedure to iterate over the processes