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

with Interfaces;       use Interfaces;
with nRF51.Clock;
with nRF51.Device;     use nRF51.Device;
with nRF51.RTC;        use nRF51.RTC;
with nRF51.Events;
with nRF51.Interrupts;

package body MicroBit.Time is

   package Clocks renames nRF51.Clock;

   Clock_Ms  : Time_Ms := 0;
   Period_Ms : constant Time_Ms := 1;

   Subscribers : array (1 .. 10) of Tick_Callback := (others => null);

   procedure Initialize;
   procedure Update_Clock;
   procedure RTC1_IRQHandler;
   pragma Export (C, RTC1_IRQHandler, "RTC1_IRQHandler");

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

   procedure Initialize is
   begin
      if not Clocks.Low_Freq_Running then
         Clocks.Set_Low_Freq_Source (Clocks.LFCLK_XTAL);
         Clocks.Start_Low_Freq;

         loop
            exit when Clocks.Low_Freq_Running;
         end loop;
      end if;

      Stop (RTC1);

      --  1kHz
      Set_Prescaler (RTC1, 0);
      Set_Compare (RTC1, 0, 16);

      Enable_Event (RTC1, Compare_0_Event);

      nRF51.Events.Enable_Interrupt (nRF51.Events.RTC_1_COMPARE_0);

      nRF51.Interrupts.Enable (nRF51.Interrupts.RTC1_Interrupt);

      Start (RTC1);
   end Initialize;

   ------------------
   -- Update_Clock --
   ------------------

   procedure Update_Clock is
   begin
      Clock_Ms := Clock_Ms + Period_Ms;
   end Update_Clock;

   ---------------------
   -- RTC1_IRQHandler --
   ---------------------

   procedure RTC1_IRQHandler is
   begin
      Stop (RTC1);
      Clear (RTC1);
      Start (RTC1);

      nRF51.Events.Clear (nRF51.Events.RTC_1_COMPARE_0);

      Update_Clock;

      for Subs of Subscribers loop

         if Subs /= null then
            --  Call the subscriber
            Subs.all;
         end if;

      end loop;
   end RTC1_IRQHandler;

   -----------
   -- Clock --
   -----------

   function Clock return Time_Ms is
   begin
      return Clock_Ms;
   end Clock;

   -----------------
   -- Tick_Period --
   -----------------

   function Tick_Period return Time_Ms is
   begin
      return Period_Ms;
   end Tick_Period;

   --------------------
   -- Tick_Subscribe --
   --------------------

   function Tick_Subscriber (Callback : not null Tick_Callback) return Boolean is
   begin
      for Subs of Subscribers loop
         if Subs = Callback then
            return True;
         end if;
      end loop;
      return False;
   end Tick_Subscriber;

   --------------------
   -- Tick_Subscribe --
   --------------------

   function Tick_Subscribe (Callback : not null Tick_Callback) return Boolean is
   begin
      for Subs of Subscribers loop
         if Subs = null then
            Subs := Callback;
            return True;
         end if;
      end loop;

      return False;
   end Tick_Subscribe;

   ----------------------
   -- Tick_Unsubscribe --
   ----------------------

   function Tick_Unsubscribe (Callback : not null Tick_Callback) return Boolean is
   begin
      for Subs of Subscribers loop
         if Subs = Callback then
            Subs := null;
            return True;
         end if;
      end loop;
      return False;
   end Tick_Unsubscribe;

begin
   Initialize;
end MicroBit.Time;

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

with Interfaces;       use Interfaces;
with nRF51.Clock;
with nRF51.Device;     use nRF51.Device;
with nRF51.RTC;        use nRF51.RTC;
with nRF51.Events;
with nRF51.Interrupts;

package body MicroBit.Time is

   package Clocks renames nRF51.Clock;

   Clock_Ms  : Time_Ms := 0;
   Period_Ms : constant Time_Ms := 1;

   Subscribers : array (1 .. 10) of Tick_Callback := (others => null);

   procedure Initialize;
   procedure Update_Clock;
   procedure RTC1_IRQHandler;
   pragma Export (C, RTC1_IRQHandler, "RTC1_IRQHandler");

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

   procedure Initialize is
   begin
      if not Clocks.Low_Freq_Running then
         Clocks.Set_Low_Freq_Source (Clocks.LFCLK_XTAL);
         Clocks.Start_Low_Freq;

         loop
            exit when Clocks.Low_Freq_Running;
         end loop;
      end if;

      Stop (RTC1);

      --  1kHz
      Set_Prescaler (RTC1, 0);
      Set_Compare (RTC1, 0, 32);

      Enable_Event (RTC1, Compare_0_Event);

      nRF51.Events.Enable_Interrupt (nRF51.Events.RTC_1_COMPARE_0);

      nRF51.Interrupts.Enable (nRF51.Interrupts.RTC1_Interrupt);

      Start (RTC1);
   end Initialize;

   ------------------
   -- Update_Clock --
   ------------------

   procedure Update_Clock is
   begin
      Clock_Ms := Clock_Ms + Period_Ms;
   end Update_Clock;

   ---------------------
   -- RTC1_IRQHandler --
   ---------------------

   procedure RTC1_IRQHandler is
   begin
      Stop (RTC1);
      Clear (RTC1);
      Start (RTC1);

      nRF51.Events.Clear (nRF51.Events.RTC_1_COMPARE_0);

      Update_Clock;

      for Subs of Subscribers loop

         if Subs /= null then
            --  Call the subscriber
            Subs.all;
         end if;

      end loop;
   end RTC1_IRQHandler;

   -----------
   -- Clock --
   -----------

   function Clock return Time_Ms is
   begin
      return Clock_Ms;
   end Clock;

   -----------------
   -- Tick_Period --
   -----------------

   function Tick_Period return Time_Ms is
   begin
      return Period_Ms;
   end Tick_Period;

   --------------------
   -- Tick_Subscribe --
   --------------------

   function Tick_Subscriber (Callback : not null Tick_Callback) return Boolean is
   begin
      for Subs of Subscribers loop
         if Subs = Callback then
            return True;
         end if;
      end loop;
      return False;
   end Tick_Subscriber;

   --------------------
   -- Tick_Subscribe --
   --------------------

   function Tick_Subscribe (Callback : not null Tick_Callback) return Boolean is
   begin
      for Subs of Subscribers loop
         if Subs = null then
            Subs := Callback;
            return True;
         end if;
      end loop;

      return False;
   end Tick_Subscribe;

   ----------------------
   -- Tick_Unsubscribe --
   ----------------------

   function Tick_Unsubscribe (Callback : not null Tick_Callback) return Boolean is
   begin
      for Subs of Subscribers loop
         if Subs = Callback then
            Subs := null;
            return True;
         end if;
      end loop;
      return False;
   end Tick_Unsubscribe;

begin
   Initialize;
end MicroBit.Time;

Fix tick frequency

MicroBit: Fix tick frequency


-----------------------------------------------------------------------
--  html -- ASF HTML Components
--  Copyright (C) 2009, 2010, 2011, 2012, 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.Exceptions;
with Ada.Unchecked_Deallocation;

with EL.Objects;

with ASF.Components.Core;
with ASF.Utils;
package body ASF.Components.Html.Text is

   use EL.Objects;

   TEXT_ATTRIBUTE_NAMES  : Util.Strings.String_Set.Set;

   LABEL_ATTRIBUTE_NAMES : Util.Strings.String_Set.Set;

   --  ------------------------------
   --  Get the local value of the component without evaluating
   --  the associated Value_Expression.
   --  ------------------------------
   overriding
   function Get_Local_Value (UI : in UIOutput) return EL.Objects.Object is
   begin
      return UI.Value;
   end Get_Local_Value;

   --  ------------------------------
   --  Get the value to write on the output.
   --  ------------------------------
   overriding
   function Get_Value (UI    : in UIOutput) return EL.Objects.Object is
   begin
      if not EL.Objects.Is_Null (UI.Value) then
         return UI.Value;
      else
         return UI.Get_Attribute (UI.Get_Context.all, "value");
      end if;
   end Get_Value;

   --  ------------------------------
   --  Set the value to write on the output.
   --  ------------------------------
   overriding
   procedure Set_Value (UI    : in out UIOutput;
                        Value : in EL.Objects.Object) is
   begin
      UI.Value := Value;
   end Set_Value;

   --  ------------------------------
   --  Get the converter that is registered on the component.
   --  ------------------------------
   overriding
   function Get_Converter (UI : in UIOutput)
                           return ASF.Converters.Converter_Access is
   begin
      return UI.Converter;
   end Get_Converter;

   --  ------------------------------
   --  Set the converter to be used on the component.
   --  ------------------------------
   overriding
   procedure Set_Converter (UI        : in out UIOutput;
                            Converter : in ASF.Converters.Converter_Access;
                            Release   : in Boolean := False) is
      use type ASF.Converters.Converter_Access;
      procedure Free is
        new Ada.Unchecked_Deallocation (Object => ASF.Converters.Converter'Class,
                                        Name   => ASF.Converters.Converter_Access);
   begin
      if UI.Release_Converter then
         Free (UI.Converter);
      end if;
      if Converter = null then
         UI.Converter := null;
         UI.Release_Converter := False;
      else
         UI.Converter := Converter.all'Unchecked_Access;
         UI.Release_Converter := Release;
      end if;
   end Set_Converter;

   --  ------------------------------
   --  Get the value of the component and apply the converter on it if there is one.
   --  ------------------------------
   function Get_Formatted_Value (UI      : in UIOutput;
                                 Context : in Faces_Context'Class) return String is
      Value : constant EL.Objects.Object := UIOutput'Class (UI).Get_Value;
   begin
      return UIOutput'Class (UI).Get_Formatted_Value (Value, Context);
   end Get_Formatted_Value;

   --  ------------------------------
   --  Format the value by appling the To_String converter on it if there is one.
   --  ------------------------------
   function Get_Formatted_Value (UI      : in UIOutput;
                                 Value   : in Util.Beans.Objects.Object;
                                 Context : in Contexts.Faces.Faces_Context'Class) return String is
      use type ASF.Converters.Converter_Access;
   begin
      if UI.Converter /= null then
         return UI.Converter.To_String (Context   => Context,
                                        Component => UI,
                                        Value     => Value);
      else
         declare
            Converter : constant access ASF.Converters.Converter'Class
              := UI.Get_Converter (Context);
         begin
            if Converter /= null then
               return Converter.To_String (Context   => Context,
                                           Component => UI,
                                           Value     => Value);
            elsif not Is_Null (Value) then
               return EL.Objects.To_String (Value);

            else
               return "";
            end if;
         end;
      end if;

      --  If the converter raises an exception, report an error in the logs.
      --  At this stage, we know the value and we can report it in this log message.
      --  We must queue the exception in the context, so this is done later.
   exception
      when E : others =>
         UI.Log_Error ("Error when converting value '{0}': {1}: {2}",
                       Util.Beans.Objects.To_String (Value),
                       Ada.Exceptions.Exception_Name (E),
                       Ada.Exceptions.Exception_Message (E));
         raise;
   end Get_Formatted_Value;

   procedure Write_Output (UI      : in UIOutput;
                           Context : in out Faces_Context'Class;
                           Value   : in String) is
      Writer : constant Response_Writer_Access := Context.Get_Response_Writer;
      Escape : constant Object := UI.Get_Attribute (Context, "escape");
   begin
      Writer.Start_Optional_Element ("span");
      UI.Render_Attributes (Context, TEXT_ATTRIBUTE_NAMES, Writer);
      if Is_Null (Escape) or To_Boolean (Escape) then
         Writer.Write_Text (Value);
      else
         Writer.Write_Raw (Value);
      end if;
      Writer.End_Optional_Element ("span");
   end Write_Output;

   procedure Encode_Begin (UI      : in UIOutput;
                           Context : in out Faces_Context'Class) is
   begin
      if UI.Is_Rendered (Context) then
         UI.Write_Output (Context => Context,
                          Value   => UIOutput'Class (UI).Get_Formatted_Value (Context));

      end if;

      --  Queue any block converter exception that could be raised.
   exception
      when E : others =>
         Context.Queue_Exception (E);
   end Encode_Begin;

   overriding
   procedure Finalize (UI : in out UIOutput) is
   begin
      UI.Set_Converter (null);
      UIHtmlComponent (UI).Finalize;
   end Finalize;

   --  ------------------------------
   --  Label Component
   --  ------------------------------

   procedure Encode_Begin (UI      : in UIOutputLabel;
                           Context : in out Faces_Context'Class) is
      Writer : Response_Writer_Access;
   begin
      if UI.Is_Rendered (Context) then
         Writer := Context.Get_Response_Writer;
         Writer.Start_Element ("label");
         UI.Render_Attributes (Context, LABEL_ATTRIBUTE_NAMES, Writer);
         declare
            Value : Util.Beans.Objects.Object := UI.Get_Attribute (Name    => "for",
                                                                   Context => Context);
         begin
            if not Util.Beans.Objects.Is_Null (Value) then
               Writer.Write_Attribute ("for", Value);
            end if;

            Value := UIOutputLabel'Class (UI).Get_Value;
            if not Util.Beans.Objects.Is_Null (Value) then
               declare
                  S : constant String
                    := UIOutputLabel'Class (UI).Get_Formatted_Value (Value, Context);
               begin
                  if UI.Get_Attribute (Name => "escape", Context => Context, Default => True) then
                     Writer.Write_Text (S);
                  else
                     Writer.Write_Raw (S);
                  end if;
               end;
            end if;

            --  Queue and block any converter exception that could be raised.
         exception
            when E : others =>
               Context.Queue_Exception (E);
         end;
      end if;
   end Encode_Begin;

   procedure Encode_End (UI      : in UIOutputLabel;
                         Context : in out Faces_Context'Class) is
      Writer : Response_Writer_Access;
   begin
      if UI.Is_Rendered (Context) then
         Writer := Context.Get_Response_Writer;
         Writer.End_Element ("label");
      end if;
   end Encode_End;

   --  ------------------------------
   --  OutputFormat Component
   --  ------------------------------
   procedure Encode_Begin (UI      : in UIOutputFormat;
                           Context : in out Faces_Context'Class) is
      use ASF.Components.Core;
      use ASF.Utils;
   begin
      if not UI.Is_Rendered (Context) then
         return;
      end if;

      declare
         Params : constant UIParameter_Access_Array := Get_Parameters (UI);
         Values : ASF.Utils.Object_Array (Params'Range);
         Result : Ada.Strings.Unbounded.Unbounded_String;
         Fmt    : constant String := EL.Objects.To_String (UI.Get_Value);
      begin
         --  Get the values associated with the parameters.
         for I in Params'Range loop
            Values (I) := Params (I).Get_Value (Context);
         end loop;
         Formats.Format (Fmt, Values, Result);
         UI.Write_Output (Context => Context,
                          Value   => To_String (Result));
      end;
   end Encode_Begin;

begin
   Utils.Set_Text_Attributes (TEXT_ATTRIBUTE_NAMES);
   Utils.Set_Text_Attributes (LABEL_ATTRIBUTE_NAMES);
   Utils.Set_Interactive_Attributes (LABEL_ATTRIBUTE_NAMES);
end ASF.Components.Html.Text;

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

with EL.Objects;

with ASF.Components.Core;
with ASF.Utils;
package body ASF.Components.Html.Text is

   use EL.Objects;

   TEXT_ATTRIBUTE_NAMES  : Util.Strings.String_Set.Set;

   LABEL_ATTRIBUTE_NAMES : Util.Strings.String_Set.Set;

   --  ------------------------------
   --  Get the local value of the component without evaluating
   --  the associated Value_Expression.
   --  ------------------------------
   overriding
   function Get_Local_Value (UI : in UIOutput) return EL.Objects.Object is
   begin
      return UI.Value;
   end Get_Local_Value;

   --  ------------------------------
   --  Get the value to write on the output.
   --  ------------------------------
   overriding
   function Get_Value (UI    : in UIOutput) return EL.Objects.Object is
   begin
      if not EL.Objects.Is_Null (UI.Value) then
         return UI.Value;
      else
         return UI.Get_Attribute (UI.Get_Context.all, "value");
      end if;
   end Get_Value;

   --  ------------------------------
   --  Set the value to write on the output.
   --  ------------------------------
   overriding
   procedure Set_Value (UI    : in out UIOutput;
                        Value : in EL.Objects.Object) is
   begin
      UI.Value := Value;
   end Set_Value;

   --  ------------------------------
   --  Get the converter that is registered on the component.
   --  ------------------------------
   overriding
   function Get_Converter (UI : in UIOutput)
                           return ASF.Converters.Converter_Access is
   begin
      return UI.Converter;
   end Get_Converter;

   --  ------------------------------
   --  Set the converter to be used on the component.
   --  ------------------------------
   overriding
   procedure Set_Converter (UI        : in out UIOutput;
                            Converter : in ASF.Converters.Converter_Access;
                            Release   : in Boolean := False) is
      use type ASF.Converters.Converter_Access;
      procedure Free is
        new Ada.Unchecked_Deallocation (Object => ASF.Converters.Converter'Class,
                                        Name   => ASF.Converters.Converter_Access);
   begin
      if UI.Release_Converter then
         Free (UI.Converter);
      end if;
      if Converter = null then
         UI.Converter := null;
         UI.Release_Converter := False;
      else
         UI.Converter := Converter.all'Unchecked_Access;
         UI.Release_Converter := Release;
      end if;
   end Set_Converter;

   --  ------------------------------
   --  Get the value of the component and apply the converter on it if there is one.
   --  ------------------------------
   function Get_Formatted_Value (UI      : in UIOutput;
                                 Context : in Faces_Context'Class) return String is
      Value : constant EL.Objects.Object := UIOutput'Class (UI).Get_Value;
   begin
      return UIOutput'Class (UI).Get_Formatted_Value (Value, Context);
   end Get_Formatted_Value;

   --  ------------------------------
   --  Get the converter associated with the component
   --  ------------------------------
   function Get_Converter (UI      : in UIOutput;
                           Context : in Faces_Context'Class)
                           return access ASF.Converters.Converter'Class is
      use type ASF.Converters.Converter_Access;
      Result : ASF.Converters.Converter_Access := UIOutput'Class (UI).Get_Converter;
   begin
      if Result /= null then
         return Result;
      else
         declare
            Name : constant EL.Objects.Object
              := UIOutput'Class (UI).Get_Attribute (Name    => CONVERTER_NAME,
                                                    Context => Context);
         begin
            return Context.Get_Converter (Name);
         end;
      end if;
   end Get_Converter;

   --  ------------------------------
   --  Format the value by appling the To_String converter on it if there is one.
   --  ------------------------------
   function Get_Formatted_Value (UI      : in UIOutput;
                                 Value   : in Util.Beans.Objects.Object;
                                 Context : in Contexts.Faces.Faces_Context'Class) return String is
      use type ASF.Converters.Converter_Access;
   begin
      if UI.Converter /= null then
         return UI.Converter.To_String (Context   => Context,
                                        Component => UI,
                                        Value     => Value);
      else
         declare
            Converter : constant access ASF.Converters.Converter'Class
              := UI.Get_Converter (Context);
         begin
            if Converter /= null then
               return Converter.To_String (Context   => Context,
                                           Component => UI,
                                           Value     => Value);
            elsif not Is_Null (Value) then
               return EL.Objects.To_String (Value);

            else
               return "";
            end if;
         end;
      end if;

      --  If the converter raises an exception, report an error in the logs.
      --  At this stage, we know the value and we can report it in this log message.
      --  We must queue the exception in the context, so this is done later.
   exception
      when E : others =>
         UI.Log_Error ("Error when converting value '{0}': {1}: {2}",
                       Util.Beans.Objects.To_String (Value),
                       Ada.Exceptions.Exception_Name (E),
                       Ada.Exceptions.Exception_Message (E));
         raise;
   end Get_Formatted_Value;

   procedure Write_Output (UI      : in UIOutput;
                           Context : in out Faces_Context'Class;
                           Value   : in String) is
      Writer : constant Response_Writer_Access := Context.Get_Response_Writer;
      Escape : constant Object := UI.Get_Attribute (Context, "escape");
   begin
      Writer.Start_Optional_Element ("span");
      UI.Render_Attributes (Context, TEXT_ATTRIBUTE_NAMES, Writer);
      if Is_Null (Escape) or To_Boolean (Escape) then
         Writer.Write_Text (Value);
      else
         Writer.Write_Raw (Value);
      end if;
      Writer.End_Optional_Element ("span");
   end Write_Output;

   procedure Encode_Begin (UI      : in UIOutput;
                           Context : in out Faces_Context'Class) is
   begin
      if UI.Is_Rendered (Context) then
         UI.Write_Output (Context => Context,
                          Value   => UIOutput'Class (UI).Get_Formatted_Value (Context));

      end if;

      --  Queue any block converter exception that could be raised.
   exception
      when E : others =>
         Context.Queue_Exception (E);
   end Encode_Begin;

   overriding
   procedure Finalize (UI : in out UIOutput) is
   begin
      UI.Set_Converter (null);
      UIHtmlComponent (UI).Finalize;
   end Finalize;

   --  ------------------------------
   --  Label Component
   --  ------------------------------

   procedure Encode_Begin (UI      : in UIOutputLabel;
                           Context : in out Faces_Context'Class) is
      Writer : Response_Writer_Access;
   begin
      if UI.Is_Rendered (Context) then
         Writer := Context.Get_Response_Writer;
         Writer.Start_Element ("label");
         UI.Render_Attributes (Context, LABEL_ATTRIBUTE_NAMES, Writer);
         declare
            Value : Util.Beans.Objects.Object := UI.Get_Attribute (Name    => "for",
                                                                   Context => Context);
         begin
            if not Util.Beans.Objects.Is_Null (Value) then
               Writer.Write_Attribute ("for", Value);
            end if;

            Value := UIOutputLabel'Class (UI).Get_Value;
            if not Util.Beans.Objects.Is_Null (Value) then
               declare
                  S : constant String
                    := UIOutputLabel'Class (UI).Get_Formatted_Value (Value, Context);
               begin
                  if UI.Get_Attribute (Name => "escape", Context => Context, Default => True) then
                     Writer.Write_Text (S);
                  else
                     Writer.Write_Raw (S);
                  end if;
               end;
            end if;

            --  Queue and block any converter exception that could be raised.
         exception
            when E : others =>
               Context.Queue_Exception (E);
         end;
      end if;
   end Encode_Begin;

   procedure Encode_End (UI      : in UIOutputLabel;
                         Context : in out Faces_Context'Class) is
      Writer : Response_Writer_Access;
   begin
      if UI.Is_Rendered (Context) then
         Writer := Context.Get_Response_Writer;
         Writer.End_Element ("label");
      end if;
   end Encode_End;

   --  ------------------------------
   --  OutputFormat Component
   --  ------------------------------
   procedure Encode_Begin (UI      : in UIOutputFormat;
                           Context : in out Faces_Context'Class) is
      use ASF.Components.Core;
      use ASF.Utils;
   begin
      if not UI.Is_Rendered (Context) then
         return;
      end if;

      declare
         Params : constant UIParameter_Access_Array := Get_Parameters (UI);
         Values : ASF.Utils.Object_Array (Params'Range);
         Result : Ada.Strings.Unbounded.Unbounded_String;
         Fmt    : constant String := EL.Objects.To_String (UI.Get_Value);
      begin
         --  Get the values associated with the parameters.
         for I in Params'Range loop
            Values (I) := Params (I).Get_Value (Context);
         end loop;
         Formats.Format (Fmt, Values, Result);
         UI.Write_Output (Context => Context,
                          Value   => To_String (Result));
      end;
   end Encode_Begin;

begin
   Utils.Set_Text_Attributes (TEXT_ATTRIBUTE_NAMES);
   Utils.Set_Text_Attributes (LABEL_ATTRIBUTE_NAMES);
   Utils.Set_Interactive_Attributes (LABEL_ATTRIBUTE_NAMES);
end ASF.Components.Html.Text;

Implement Get_Converter function (moved from AWA.Components.Base package


--  SPDX-License-Identifier: Apache-2.0
--
--  Copyright (c) 2017 onox <denkpadje@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.

limited with Orka.Contexts;

with Orka.Inputs.Pointers;

package Orka.Windows is
   pragma Preelaborate;

   type Window is limited interface;

   type Window_Ptr is not null access all Window'Class;

   function Create_Window
     (Context            : Contexts.Surface_Context'Class;
      Width, Height      : Positive;
      Title              : String  := "";
      Samples            : Natural := 0;
      Visible, Resizable : Boolean := True;
      Transparent        : Boolean := False) return Window is abstract;

   function Pointer_Input
     (Object : Window) return Inputs.Pointers.Pointer_Input_Ptr is abstract;

   function Width (Object : Window) return Positive is abstract;

   function Height (Object : Window) return Positive is abstract;

   procedure Set_Title (Object : in out Window; Value : String) is abstract;
   --  Set the title of the window
   --
   --  Task safety: Must only be called from the environment task.

   procedure Close (Object : in out Window) is abstract;

   function Should_Close (Object : Window) return Boolean is abstract;

   procedure Process_Input (Object : in out Window) is abstract;
   --  Process window and input events
   --
   --  Task safety: Must only be called from the environment task.

   procedure Swap_Buffers (Object : in out Window) is abstract;
   --  Swap the front and back buffers of the window
   --
   --  Task safety: Must only be called from the rendering task.

   procedure Set_Vertical_Sync (Object : in out Window; Enable : Boolean) is abstract;
   --  Request the vertical retrace synchronization or vsync to be enabled
   --  or disabled
   --
   --  Vsync causes the video driver to wait for a screen update before
   --  swapping the buffers. The video driver may ignore the request.
   --  Enablng vsync avoids tearing.

end Orka.Windows;

--  SPDX-License-Identifier: Apache-2.0
--
--  Copyright (c) 2017 onox <denkpadje@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.

limited with Orka.Contexts;

with Orka.Inputs.Pointers;

package Orka.Windows is
   pragma Preelaborate;

   type Window is limited interface;

   function Create_Window
     (Context            : Contexts.Surface_Context'Class;
      Width, Height      : Positive;
      Title              : String  := "";
      Samples            : Natural := 0;
      Visible, Resizable : Boolean := True;
      Transparent        : Boolean := False) return Window is abstract;

   function Pointer_Input
     (Object : Window) return Inputs.Pointers.Pointer_Input_Ptr is abstract;

   function Width (Object : Window) return Positive is abstract;

   function Height (Object : Window) return Positive is abstract;

   procedure Set_Title (Object : in out Window; Value : String) is abstract;
   --  Set the title of the window
   --
   --  Task safety: Must only be called from the environment task.

   procedure Close (Object : in out Window) is abstract;

   function Should_Close (Object : Window) return Boolean is abstract;

   procedure Swap_Buffers (Object : in out Window) is abstract;
   --  Swap the front and back buffers of the window
   --
   --  Task safety: Must only be called from the rendering task.

   procedure Set_Vertical_Sync (Object : in out Window; Enable : Boolean) is abstract;
   --  Request the vertical retrace synchronization or vsync to be enabled
   --  or disabled
   --
   --  Vsync causes the video driver to wait for a screen update before
   --  swapping the buffers. The video driver may ignore the request.
   --  Enablng vsync avoids tearing.

end Orka.Windows;

orka: Remove type Window_Ptr and procedure Process_Input in Orka.Windows

Type Window_Ptr is no longer needed after removing the parameter Window
from the generic package Orka.Loops. Procedure Process_Input is removed
since AWT.Process_Events will process input (and other) events for the
focused window, not necessarily the used Window object.

Signed-off-by: onox <34c1d3d2d1347bea60a26f46574de21a7a79b6d5@gmail.com>


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

with GNAT.Command_Line;

with Util.Files;

with Wiki.Utils;

procedure Render is

   use GNAT.Command_Line;
   use Ada.Strings.Unbounded;
   use Ada.Characters.Conversions;

   procedure Usage;

   procedure Usage is
   begin
      Ada.Text_IO.Put_Line ("Render a wiki text file into HTML (default) or text");
      Ada.Text_IO.Put_Line ("Usage: render [-t] [-m] [-M] [-d] [-c] {wiki-file}");
      Ada.Text_IO.Put_Line ("  -t      Render to text only");
      Ada.Text_IO.Put_Line ("  -m      Render a Markdown wiki content");
      Ada.Text_IO.Put_Line ("  -M      Render a Mediawiki wiki content");
      Ada.Text_IO.Put_Line ("  -d      Render a Dotclear wiki content");
      Ada.Text_IO.Put_Line ("  -g      Render a Google wiki content");
      Ada.Text_IO.Put_Line ("  -c      Render a Creole wiki content");
   end Usage;

   Count     : Natural := 0;
   Html_Mode : Boolean := True;
   Syntax    : Wiki.Wiki_Syntax := Wiki.SYNTAX_MARKDOWN;
begin
   loop
      case Getopt ("m M d c g t") is
         when 'm' =>
            Syntax := Wiki.SYNTAX_MARKDOWN;

         when 'M' =>
            Syntax := Wiki.SYNTAX_MEDIA_WIKI;

         when 'c' =>
            Syntax := Wiki.SYNTAX_CREOLE;

         when 'd' =>
            Syntax := Wiki.SYNTAX_DOTCLEAR;

         when 'g' =>
            Syntax := Wiki.SYNTAX_GOOGLE;

         when 't' =>
            Html_Mode := False;

         when others =>
            exit;
      end case;
   end loop;

   loop
      declare
         Name : constant String := GNAT.Command_Line.Get_Argument;
         Data : Unbounded_String;
      begin
         if Name = "" then
            if Count = 0 then
               Usage;
            end if;
            return;
         end if;
         Count := Count + 1;
         Util.Files.Read_File (Name, Data);
         if Html_Mode then
            Ada.Text_IO.Put_Line
              (Wiki.Utils.To_Html (To_Wide_Wide_String (To_String (Data)), Syntax));
         else
            Ada.Text_IO.Put_Line
              (Wiki.Utils.To_Text (To_Wide_Wide_String (To_String (Data)), Syntax));
         end if;
      exception
         when Ada.IO_Exceptions.Name_Error =>
            Ada.Text_IO.Put_Line ("Cannot read file '" & Name & "'");

      end;
   end loop;

exception
   when Invalid_Switch =>
      Ada.Text_IO.Put_Line ("Invalid option.");
      Usage;
end Render;

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

with GNAT.Command_Line;

with Wiki.Documents;
with Wiki.Parsers;
with Wiki.Filters.TOC;
with Wiki.Filters.Html;
with Wiki.Render.Html;
with Wiki.Render.Text;
with Wiki.Streams.Text_IO;
with Wiki.Streams.Html.Text_IO;

procedure Render is

   use GNAT.Command_Line;
   use Ada.Strings.Unbounded;

   procedure Usage;
   procedure Render_Html (Doc   : in out Wiki.Documents.Document;
                          Style : in Unbounded_String);
   procedure Render_Text (Doc : in out Wiki.Documents.Document);

   procedure Usage is
   begin
      Ada.Text_IO.Put_Line ("Render a wiki text file into HTML (default) or text");
      Ada.Text_IO.Put_Line ("Usage: render [-t] [-m] [-M] [-d] [-c] [-s style] {wiki-file}");
      Ada.Text_IO.Put_Line ("  -t        Render to text only");
      Ada.Text_IO.Put_Line ("  -m        Render a Markdown wiki content");
      Ada.Text_IO.Put_Line ("  -M        Render a Mediawiki wiki content");
      Ada.Text_IO.Put_Line ("  -d        Render a Dotclear wiki content");
      Ada.Text_IO.Put_Line ("  -g        Render a Google wiki content");
      Ada.Text_IO.Put_Line ("  -c        Render a Creole wiki content");
      Ada.Text_IO.Put_Line ("  -s style  Use the CSS style file");
   end Usage;

   procedure Render_Html (Doc   : in out Wiki.Documents.Document;
                          Style : in Unbounded_String) is
      Output   : aliased Wiki.Streams.Html.Text_IO.Html_File_Output_Stream;
      Renderer : aliased Wiki.Render.Html.Html_Renderer;
   begin
      if Length (Style) > 0 then
         Output.Start_Element ("html");
         Output.Start_Element ("head");
         Output.Start_Element ("link");
         Output.Write_Attribute ("type", "text/css");
         Output.Write_Attribute ("rel", "stylesheet");
         Output.Write_Attribute ("href", To_String (Style));
         Output.End_Element ("link");
         Output.End_Element ("head");
         Output.Start_Element ("body");
      end if;
      Renderer.Set_Output_Stream (Output'Unchecked_Access);
      Renderer.Set_Render_TOC (True);
      Renderer.Render (Doc);
      if Length (Style) > 0 then
         Output.End_Element ("body");
         Output.End_Element ("html");
      end if;
   end Render_Html;

   procedure Render_Text (Doc : in out Wiki.Documents.Document) is
      Output   : aliased Wiki.Streams.Text_IO.File_Output_Stream;
      Renderer : aliased Wiki.Render.Text.Text_Renderer;
   begin
      Renderer.Set_Output_Stream (Output'Unchecked_Access);
      Renderer.Render (Doc);
   end Render_Text;

   Count     : Natural := 0;
   Html_Mode : Boolean := True;
   Syntax    : Wiki.Wiki_Syntax := Wiki.SYNTAX_MARKDOWN;
   Style     : Unbounded_String;
begin
   loop
      case Getopt ("m M d c g t s:") is
         when 'm' =>
            Syntax := Wiki.SYNTAX_MARKDOWN;

         when 'M' =>
            Syntax := Wiki.SYNTAX_MEDIA_WIKI;

         when 'c' =>
            Syntax := Wiki.SYNTAX_CREOLE;

         when 'd' =>
            Syntax := Wiki.SYNTAX_DOTCLEAR;

         when 'g' =>
            Syntax := Wiki.SYNTAX_GOOGLE;

         when 't' =>
            Html_Mode := False;

         when 's' =>
            Style := To_Unbounded_String (Parameter);

         when others =>
            exit;
      end case;
   end loop;

   loop
      declare
         Name     : constant String := GNAT.Command_Line.Get_Argument;
         Input    : aliased Wiki.Streams.Text_IO.File_Input_Stream;
         Filter   : aliased Wiki.Filters.Html.Html_Filter_Type;
         TOC      : aliased Wiki.Filters.TOC.TOC_Filter;
         Doc      : Wiki.Documents.Document;
         Engine   : Wiki.Parsers.Parser;
      begin
         if Name = "" then
            if Count = 0 then
               Usage;
            end if;
            return;
         end if;
         Count := Count + 1;

         --  Open the file and parse it (assume UTF-8).
         Input.Open (Name, "WCEM=8");
         Engine.Add_Filter (TOC'Unchecked_Access);
         Engine.Add_Filter (Filter'Unchecked_Access);
         Engine.Set_Syntax (Syntax);
         Engine.Parse (Input'Unchecked_Access, Doc);

         --  Render the document in text or HTML.
         if Html_Mode then
            Render_Html (Doc, Style);
         else
            Render_Text (Doc);
         end if;

      exception
         when Ada.IO_Exceptions.Name_Error =>
            Ada.Text_IO.Put_Line ("Cannot read file '" & Name & "'");

      end;
   end loop;

exception
   when Invalid_Switch =>
      Ada.Text_IO.Put_Line ("Invalid option.");
      Usage;
end Render;

Use the Text_IO streams to read and write the result Add a -s <style> option to emit a HTML head with CSS style


-----------------------------------------------------------------------
--  EL.Beans.Tests - Testsuite for EL.Beans
--  Copyright (C) 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 Util.Test_Caller;

with Test_Bean;
with Util.Beans.Objects;
with EL.Contexts.Default;
package body EL.Beans.Tests is

   use Util.Tests;
   use Util.Beans.Objects;
   use Test_Bean;

   package Caller is new Util.Test_Caller (Test);

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test EL.Beans.Add_Parameter",
                       Test_Add_Parameter'Access);
      Caller.Add_Test (Suite, "Test EL.Beans.Initialize",
                       Test_Initialize'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test Add_Parameter
   --  ------------------------------
   procedure Test_Add_Parameter (T : in out Test) is
      P       : Param_Vectors.Vector;
      Context : EL.Contexts.Default.Default_Context;
   begin
      --  Add a constant parameter.
      Add_Parameter (Container => P,
                     Name      => "firstName",
                     Value     => "my name",
                     Context   => Context);
      Assert_Equals (T, 1, Integer (P.Length), "Parameter was not added");
      T.Assert_Equals ("firstName", P.Element (1).Name, "Invalid parameter name");
      T.Assert (P.Element (1).Value.Is_Constant, "Value should be a constant");
      T.Assert_Equals ("my name",
                       Util.Beans.Objects.To_String (P.Element (1).Value.Get_Value (Context)),
                       "Invalid value");

      --  Add an expression parameter.
      Add_Parameter (Container => P,
                     Name      => "lastName",
                     Value     => "#{name}",
                     Context   => Context);
      Assert_Equals (T, 2, Integer (P.Length), "Parameter was not added");
   end Test_Add_Parameter;

   --  ------------------------------
   --  Test the Initialize procedure with a set of expressions
   --  ------------------------------
   procedure Test_Initialize (T : in out Test) is
      P       : Param_Vectors.Vector;
      Context : EL.Contexts.Default.Default_Context;
      User    : Person_Access := Create_Person ("Joe", "Black", 42);
      Bean    : Person_Access := Create_Person ("", "", 0);
   begin
      Context.Set_Variable ("user", User);
      Add_Parameter (P, "firstName", "#{user.firstName}", Context);
      Add_Parameter (P, "lastName", "#{user.lastName}", Context);
      Add_Parameter (P, "age", "#{user.age + 2}", Context);

      Initialize (Bean.all, P, Context);
      T.Assert_Equals ("Joe", Bean.First_Name, "First name not initialized");
      T.Assert_Equals ("Black", Bean.Last_Name, "Last name not initialized");
      Assert_Equals (T, 44, Integer (Bean.Age), "Age was not initialized");
      Free (Bean);
      Free (User);
   end Test_Initialize;

end EL.Beans.Tests;

-----------------------------------------------------------------------
--  EL.Beans.Tests - Testsuite for EL.Beans
--  Copyright (C) 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 Util.Test_Caller;

with Test_Bean;
with Util.Beans.Objects;
with EL.Contexts.Default;
package body EL.Beans.Tests is

   use Util.Tests;
   use Util.Beans.Objects;
   use Test_Bean;

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test EL.Beans.Add_Parameter",
                       Test_Add_Parameter'Access);
      Caller.Add_Test (Suite, "Test EL.Beans.Initialize",
                       Test_Initialize'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test Add_Parameter
   --  ------------------------------
   procedure Test_Add_Parameter (T : in out Test) is
      P       : Param_Vectors.Vector;
      Context : EL.Contexts.Default.Default_Context;
   begin
      --  Add a constant parameter.
      Add_Parameter (Container => P,
                     Name      => "firstName",
                     Value     => "my name",
                     Context   => Context);
      Assert_Equals (T, 1, Integer (P.Length), "Parameter was not added");
      T.Assert_Equals ("firstName", P.Element (1).Name, "Invalid parameter name");
      T.Assert (P.Element (1).Value.Is_Constant, "Value should be a constant");
      T.Assert_Equals ("my name",
                       Util.Beans.Objects.To_String (P.Element (1).Value.Get_Value (Context)),
                       "Invalid value");

      --  Add an expression parameter.
      Add_Parameter (Container => P,
                     Name      => "lastName",
                     Value     => "#{name}",
                     Context   => Context);
      Assert_Equals (T, 2, Integer (P.Length), "Parameter was not added");
   end Test_Add_Parameter;

   --  ------------------------------
   --  Test the Initialize procedure with a set of expressions
   --  ------------------------------
   procedure Test_Initialize (T : in out Test) is
      P       : Param_Vectors.Vector;
      Context : EL.Contexts.Default.Default_Context;
      User    : Person_Access := Create_Person ("Joe", "Black", 42);
      Bean    : Person_Access := Create_Person ("", "", 0);
   begin
      Context.Set_Variable ("user", User);
      Add_Parameter (P, "firstName", "#{user.firstName}", Context);
      Add_Parameter (P, "lastName", "#{user.lastName}", Context);
      Add_Parameter (P, "age", "#{user.age + 2}", Context);

      Initialize (Bean.all, P, Context);
      T.Assert_Equals ("Joe", Bean.First_Name, "First name not initialized");
      T.Assert_Equals ("Black", Bean.Last_Name, "Last name not initialized");
      Assert_Equals (T, 44, Integer (Bean.Age), "Age was not initialized");
      Free (Bean);
      Free (User);
   end Test_Initialize;

end EL.Beans.Tests;

Use the test name EL.Beans

Use the test name EL.Beans


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

with ASF.Events.Faces.Actions;
package body Messages is

   use Ada.Strings.Unbounded;

   Database : aliased Forum;

   --  ------------------------------
   --  Get the value identified by the name.
   --  ------------------------------
   function Get_Value (From : in Message_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "text" then
         return Util.Beans.Objects.To_Object (From.Text);

      elsif Name = "email" then
         return Util.Beans.Objects.To_Object (From.Email);

      elsif Name = "id" then
         return Util.Beans.Objects.To_Object (Integer (From.Id));
      else
         return Util.Beans.Objects.Null_Object;
      end if;
   end Get_Value;

   --  ------------------------------
   --  Set the value identified by the name.
   --  ------------------------------
   procedure Set_Value (From  : in out Message_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = "text" then
         From.Text := Util.Beans.Objects.To_Unbounded_String (Value);

      elsif Name = "email" then
         From.Email := Util.Beans.Objects.To_Unbounded_String (Value);

      elsif Name = "id" then
         From.Id := Message_Id (Util.Beans.Objects.To_Integer (Value));

      end if;
   end Set_Value;

   --  ------------------------------
   --  Post the message.
   --  ------------------------------
   procedure Post (From    : in out Message_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
   begin
      if Length (From.Text) > 200 then
         Ada.Strings.Unbounded.Replace_Slice (From.Text, 200, Length (From.Text), "...");
      end if;
      Database.Post (From);
      Outcome := To_Unbounded_String ("posted");
   end Post;

   package Post_Binding is
     new ASF.Events.Faces.Actions.Action_Method.Bind (Bean   => Message_Bean,
                                                      Method => Post,
                                                      Name   => "post");

   Binding_Array : aliased constant Util.Beans.Methods.Method_Binding_Array
     := (Post_Binding.Proxy'Unchecked_Access, Post_Binding.Proxy'Unchecked_Access);

   --  ------------------------------
   --  This bean provides some methods that can be used in a Method_Expression
   --  ------------------------------
   overriding
   function Get_Method_Bindings (From : in Message_Bean)
                                 return Util.Beans.Methods.Method_Binding_Array_Access is
      pragma Unreferenced (From);
   begin
      return Binding_Array'Access;
   end Get_Method_Bindings;

   --  ------------------------------
   --  Create a message bean instance.
   --  ------------------------------
   function Create_Message_Bean return Util.Beans.Basic.Readonly_Bean_Access is
      Result : constant Message_Bean_Access := new Message_Bean;
   begin
      return Result.all'Access;
   end Create_Message_Bean;

   --  ------------------------------
   --  Get the value identified by the name.
   --  ------------------------------
   overriding
   function Get_Value (From : in Forum_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "count" then
         return Util.Beans.Objects.To_Object (Integer (From.Get_Count));
      else
         return Util.Beans.Objects.Null_Object;
      end if;
   end Get_Value;

   --  ------------------------------
   --  Get the number of elements in the list.
   --  ------------------------------
   overriding
   function Get_Count (From : in Forum_Bean) return Natural is
      pragma Unreferenced (From);
   begin
      return Database.Get_Message_Count;
   end Get_Count;

   --  ------------------------------
   --  Set the current row index.  Valid row indexes start at 1.
   --  ------------------------------
   overriding
   procedure Set_Row_Index (From  : in out Forum_Bean;
                            Index : in Natural) is
   begin
      From.Pos := Message_Id (Index);
      From.Msg := Database.Get_Message (From.Pos);
   end Set_Row_Index;

   --  ------------------------------
   --  Get the element at the current row index.
   --  ------------------------------
   overriding
   function Get_Row (From  : in Forum_Bean) return Util.Beans.Objects.Object is
   begin
      return From.Current;
   end Get_Row;

   --  ------------------------------
   --  Create the list of messages.
   --  ------------------------------
   function Create_Message_List return Util.Beans.Basic.Readonly_Bean_Access is
      F : constant Forum_Bean_Access := new Forum_Bean;
   begin
      F.Current := Util.Beans.Objects.To_Object (F.Msg'Access, Util.Beans.Objects.STATIC);
      return F.all'Access;
   end Create_Message_List;

   protected body Forum is

      --  ------------------------------
      --  Post the message in the forum.
      --  ------------------------------
      procedure Post (Message : in Message_Bean) is
         use type Ada.Containers.Count_Type;
      begin
         if Messages.Length > 100 then
            Messages.Delete (Message_Id'First);
         end if;
         Messages.Append (Message);
      end Post;

      --  ------------------------------
      --  Delete the message identified by Id.
      --  ------------------------------
      procedure Delete (Id : in Message_Id) is
      begin
         Messages.Delete (Id);
      end Delete;

      --  ------------------------------
      --  Get the message identified by Id.
      --  ------------------------------
      function Get_Message (Id : in Message_Id) return Message_Bean is
      begin
         return Messages.Element (Id);
      end Get_Message;

      --  ------------------------------
      --  Get the number of messages in the forum.
      --  ------------------------------
      function Get_Message_Count return Natural is
      begin
         return Natural (Messages.Length);
      end Get_Message_Count;

   end Forum;

end Messages;

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

   use Ada.Strings.Unbounded;

   Database : aliased Forum;

   --  ------------------------------
   --  Get the value identified by the name.
   --  ------------------------------
   function Get_Value (From : in Message_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "text" then
         return Util.Beans.Objects.To_Object (From.Text);

      elsif Name = "email" then
         return Util.Beans.Objects.To_Object (From.Email);

      elsif Name = "id" then
         return Util.Beans.Objects.To_Object (Integer (From.Id));
      else
         return Util.Beans.Objects.Null_Object;
      end if;
   end Get_Value;

   --  ------------------------------
   --  Set the value identified by the name.
   --  ------------------------------
   procedure Set_Value (From  : in out Message_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = "text" then
         From.Text := Util.Beans.Objects.To_Unbounded_String (Value);

      elsif Name = "email" then
         From.Email := Util.Beans.Objects.To_Unbounded_String (Value);

      elsif Name = "id" then
         From.Id := Message_Id (Util.Beans.Objects.To_Integer (Value));

      end if;
   end Set_Value;

   --  ------------------------------
   --  Post the message.
   --  ------------------------------
   procedure Post (From    : in out Message_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
   begin
      if Length (From.Text) > 200 then
         Ada.Strings.Unbounded.Replace_Slice (From.Text, 200, Length (From.Text), "...");
      end if;
      Database.Post (From);
      Outcome := To_Unbounded_String ("posted");
   end Post;

   package Post_Binding is
     new ASF.Events.Faces.Actions.Action_Method.Bind (Bean   => Message_Bean,
                                                      Method => Post,
                                                      Name   => "post");

   Binding_Array : aliased constant Util.Beans.Methods.Method_Binding_Array
     := (Post_Binding.Proxy'Unchecked_Access, Post_Binding.Proxy'Unchecked_Access);

   --  ------------------------------
   --  This bean provides some methods that can be used in a Method_Expression
   --  ------------------------------
   overriding
   function Get_Method_Bindings (From : in Message_Bean)
                                 return Util.Beans.Methods.Method_Binding_Array_Access is
      pragma Unreferenced (From);
   begin
      return Binding_Array'Access;
   end Get_Method_Bindings;

   --  ------------------------------
   --  Create a message bean instance.
   --  ------------------------------
   function Create_Message_Bean return Util.Beans.Basic.Readonly_Bean_Access is
      Result : constant Message_Bean_Access := new Message_Bean;
   begin
      return Result.all'Access;
   end Create_Message_Bean;

   --  ------------------------------
   --  Get the value identified by the name.
   --  ------------------------------
   overriding
   function Get_Value (From : in Forum_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "count" then
         return Util.Beans.Objects.To_Object (Integer (From.Get_Count));
      elsif Name = "today" then
         return Util.Beans.Objects.Time.To_Object (Ada.Calendar.Clock);
      else
         return Util.Beans.Objects.Null_Object;
      end if;
   end Get_Value;

   --  ------------------------------
   --  Get the number of elements in the list.
   --  ------------------------------
   overriding
   function Get_Count (From : in Forum_Bean) return Natural is
      pragma Unreferenced (From);
   begin
      return Database.Get_Message_Count;
   end Get_Count;

   --  ------------------------------
   --  Set the current row index.  Valid row indexes start at 1.
   --  ------------------------------
   overriding
   procedure Set_Row_Index (From  : in out Forum_Bean;
                            Index : in Natural) is
   begin
      From.Pos := Message_Id (Index);
      From.Msg := Database.Get_Message (From.Pos);
   end Set_Row_Index;

   --  ------------------------------
   --  Get the element at the current row index.
   --  ------------------------------
   overriding
   function Get_Row (From  : in Forum_Bean) return Util.Beans.Objects.Object is
   begin
      return From.Current;
   end Get_Row;

   --  ------------------------------
   --  Create the list of messages.
   --  ------------------------------
   function Create_Message_List return Util.Beans.Basic.Readonly_Bean_Access is
      F : constant Forum_Bean_Access := new Forum_Bean;
   begin
      F.Current := Util.Beans.Objects.To_Object (F.Msg'Access, Util.Beans.Objects.STATIC);
      return F.all'Access;
   end Create_Message_List;

   protected body Forum is

      --  ------------------------------
      --  Post the message in the forum.
      --  ------------------------------
      procedure Post (Message : in Message_Bean) is
         use type Ada.Containers.Count_Type;
      begin
         if Messages.Length > 100 then
            Messages.Delete (Message_Id'First);
         end if;
         Messages.Append (Message);
      end Post;

      --  ------------------------------
      --  Delete the message identified by Id.
      --  ------------------------------
      procedure Delete (Id : in Message_Id) is
      begin
         Messages.Delete (Id);
      end Delete;

      --  ------------------------------
      --  Get the message identified by Id.
      --  ------------------------------
      function Get_Message (Id : in Message_Id) return Message_Bean is
      begin
         return Messages.Element (Id);
      end Get_Message;

      --  ------------------------------
      --  Get the number of messages in the forum.
      --  ------------------------------
      function Get_Message_Count return Natural is
      begin
         return Natural (Messages.Length);
      end Get_Message_Count;

   end Forum;

end Messages;

Add a bean value 'today' to retrieve the current date and time in an XHTML view


-----------------------------------------------------------------------
--  util-events-timers-tests -- Unit tests for timers
--  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 Util.Tests;

package Util.Events.Timers.Tests is

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

   type Test is new Util.Tests.Test
     and Util.Events.Timers.Timer with record
      Count  : Natural := 0;
      Repeat : Natural := 0;
   end record;

   overriding
   procedure Time_Handler (Sub   : in out Test;
                           Event : in out Timer_Ref'Class);

   --  Test empty timers.
   procedure Test_Empty_Timer (T : in out Test);

   procedure Test_Timer_Event (T : in out Test);

   --  Test repeating timers.
   procedure Test_Repeat_Timer (T : in out Test);

end Util.Events.Timers.Tests;

-----------------------------------------------------------------------
--  util-events-timers-tests -- Unit tests for timers
--  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 Util.Tests;

package Util.Events.Timers.Tests is

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

   type Test is new Util.Tests.Test
     and Util.Events.Timers.Timer with record
      Count  : Natural := 0;
      Repeat : Natural := 0;
   end record;

   overriding
   procedure Time_Handler (Sub   : in out Test;
                           Event : in out Timer_Ref'Class);

   --  Test empty timers.
   procedure Test_Empty_Timer (T : in out Test);

   procedure Test_Timer_Event (T : in out Test);

   --  Test repeating timers.
   procedure Test_Repeat_Timer (T : in out Test);

   --  Test executing several timers.
   procedure Test_Many_Timers (T : in out Test);

end Util.Events.Timers.Tests;

Declare the Test_Many_Timers procedure

Declare the Test_Many_Timers procedure


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

with ADO;
with AWA.Modules;
with AWA.Modules.Get;
with AWA.Comments.Models;
package AWA.Comments.Modules is

   NAME : constant String := "comments";

   type Comment_Module is new AWA.Modules.Module with null record;
   type Comment_Module_Access is access all Comment_Module'Class;

   overriding
   procedure Initialize (Plugin : in out Comment_Module;
                         App    : in AWA.Modules.Application_Access;
                         Props  : in ASF.Applications.Config);

   --  Load the comment identified by the given identifier.
   procedure Load_Comment (Model   : in Comment_Module;
                           Comment : in out AWA.Comments.Models.Comment_Ref'Class;
                           Id      : in ADO.Identifier);

   --  Create a new comment for the associated database entity.
   procedure Create_Comment (Model      : in Comment_Module;
                             Permission : in String;
                             Comment    : in out AWA.Comments.Models.Comment_Ref'Class);

   function Get_Comment_Module is
     new AWA.Modules.Get (Comment_Module, Comment_Module_Access, NAME);

end AWA.Comments.Modules;

-----------------------------------------------------------------------
--  awa-comments-module -- Comments module
--  Copyright (C) 2011, 2012, 2013, 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 ASF.Applications;

with ADO;
with AWA.Modules;
with AWA.Modules.Get;
with AWA.Comments.Models;
package AWA.Comments.Modules is

   NAME : constant String := "comments";

   type Comment_Module is new AWA.Modules.Module with null record;
   type Comment_Module_Access is access all Comment_Module'Class;

   overriding
   procedure Initialize (Plugin : in out Comment_Module;
                         App    : in AWA.Modules.Application_Access;
                         Props  : in ASF.Applications.Config);

   --  Load the comment identified by the given identifier.
   procedure Load_Comment (Model   : in Comment_Module;
                           Comment : in out AWA.Comments.Models.Comment_Ref'Class;
                           Id      : in ADO.Identifier);

   --  Create a new comment for the associated database entity.
   procedure Create_Comment (Model       : in Comment_Module;
                             Permission  : in String;
                             Entity_Type : in String;
                             Comment     : in out AWA.Comments.Models.Comment_Ref'Class);

   function Get_Comment_Module is
     new AWA.Modules.Get (Comment_Module, Comment_Module_Access, NAME);

end AWA.Comments.Modules;

Change the Create_Comment to specify the entity type


-----------------------------------------------------------------------
--  security-policies -- Security Policies
--  Copyright (C) 2010, 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.Finalization;
with Ada.Strings.Unbounded;

with Ada.Containers.Hashed_Maps;
with Ada.Containers.Vectors;

with Util.Strings;
with Util.Refs;
with Util.Beans.Objects;
with Util.Beans.Objects.Vectors;
with Util.Serialize.IO.XML;

with GNAT.Regexp;

with Security.Permissions;
limited with Security.Controllers;
limited with Security.Contexts;

package Security.Policies is

   type Policy is new Ada.Finalization.Limited_Controlled with null record;
   type Policy_Access is access all Policy'Class;

   procedure Set_Reader_Config (Pol     : in out Policy;
                                Reader  : in out Util.Serialize.IO.XML.Parser) is null;

   --  Get the policy name.
   function Get_Name (From : in Policy) return String;

   Invalid_Name : exception;

   type Security_Context_Access is access all Contexts.Security_Context'Class;

   type Controller_Access is access all Security.Controllers.Controller'Class;

   type Controller_Access_Array is array (Permissions.Permission_Index range <>) of Controller_Access;

   --  Each permission is represented by a Permission_Type number to provide a fast
   --  and efficient permission check.
   type Permission_Type is new Natural range 0 .. 63;

   --  The Permission_Map represents a set of permissions which are granted to a user.
   --  Each permission is represented by a boolean in the map.  The implementation is limited
   --  to 64 permissions.
   type Permission_Map is array (Permission_Type'Range) of Boolean;
   pragma Pack (Permission_Map);

   --  ------------------------------
   --  Permission Manager
   --  ------------------------------
   --  The Permission_Manager verifies through some policy that a permission
   --  is granted to a user.
   type Policy_Manager is new Ada.Finalization.Limited_Controlled with private;
   type Policy_Manager_Access is access all Policy_Manager'Class;

   --  Add the policy to the policy manager.  After a policy is added in the manager,
   --  it can participate in the security policy.
   procedure Add_Policy (Manager : in out Policy_Manager;
                         Policy  : in Policy_Access);

   procedure Add_Permission (Manager    : in out Policy_Manager;
                             Name       : in String;
                             Permission : in Controller_Access);

   --  Get the security controller associated with the permission index Index.
   --  Returns null if there is no such controller.
   function Get_Controller (Manager : in Policy_Manager'Class;
                            Index   : in Permissions.Permission_Index) return Controller_Access;
   pragma Inline_Always (Get_Controller);

   --  Read the policy file
   procedure Read_Policy (Manager : in out Policy_Manager;
                          File    : in String);

   --  Initialize the permission manager.
   overriding
   procedure Initialize (Manager : in out Policy_Manager);

   --  Finalize the permission manager.
   overriding
   procedure Finalize (Manager : in out Policy_Manager);

   --  ------------------------------
   --  Policy Configuration
   --  ------------------------------
   type Policy_Config is record
      Id          : Natural := 0;
      Permissions : Util.Beans.Objects.Vectors.Vector;
      Patterns    : Util.Beans.Objects.Vectors.Vector;
      Manager     : Policy_Manager_Access;
   end record;
   type Policy_Config_Access is access all Policy_Config;

   --  Setup the XML parser to read the policy description.  For example:
   --
   --  <policy id='1'>
   --     <permission>create-workspace</permission>
   --     <permission>admin</permission>
   --     <url-pattern>/workspace/create</url-pattern>
   --     <url-pattern>/workspace/setup/*</url-pattern>
   --  </policy>
   --
   --  This policy gives access to the URL that match one of the URL pattern if the
   --  security context has the permission create-workspace or admin.
   generic
      Reader  : in out Util.Serialize.IO.XML.Parser;
      Manager : in Policy_Manager_Access;
   package Reader_Config is
      Config : aliased Policy_Config;
   end Reader_Config;

private

   use Util.Strings;

   subtype Permission_Index is Permissions.Permission_Index;

   type Permission_Type_Array is array (1 .. 10) of Permission_Type;

   type Permission_Index_Array is array (Positive range <>) of Permissions.Permission_Index;

   type Controller_Access_Array_Access is access all Controller_Access_Array;

   type Policy_Manager is new Ada.Finalization.Limited_Controlled with record
--        Cache        : Rules_Ref_Access;
--        Policies     : Policy_Vector.Vector;
      Permissions  : Controller_Access_Array_Access;
      Last_Index   : Permission_Index := Permission_Index'First;
   end record;

end Security.Policies;

-----------------------------------------------------------------------
--  security-policies -- Security Policies
--  Copyright (C) 2010, 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.Finalization;
with Ada.Strings.Unbounded;

with Ada.Containers.Hashed_Maps;
with Ada.Containers.Vectors;

with Util.Strings;
with Util.Refs;
with Util.Beans.Objects;
with Util.Beans.Objects.Vectors;
with Util.Serialize.IO.XML;

with GNAT.Regexp;

with Security.Permissions;
limited with Security.Controllers;
limited with Security.Contexts;

package Security.Policies is

   type Policy is new Ada.Finalization.Limited_Controlled with null record;
   type Policy_Access is access all Policy'Class;

   procedure Set_Reader_Config (Pol     : in out Policy;
                                Reader  : in out Util.Serialize.IO.XML.Parser) is null;

   --  Get the policy name.
   function Get_Name (From : in Policy) return String;

   Invalid_Name : exception;

   type Security_Context_Access is access all Contexts.Security_Context'Class;

   type Controller_Access is access all Security.Controllers.Controller'Class;

   type Controller_Access_Array is array (Permissions.Permission_Index range <>) of Controller_Access;

   --  Each permission is represented by a Permission_Type number to provide a fast
   --  and efficient permission check.
   type Permission_Type is new Natural range 0 .. 63;

   --  The Permission_Map represents a set of permissions which are granted to a user.
   --  Each permission is represented by a boolean in the map.  The implementation is limited
   --  to 64 permissions.
   type Permission_Map is array (Permission_Type'Range) of Boolean;
   pragma Pack (Permission_Map);

   --  ------------------------------
   --  Permission Manager
   --  ------------------------------
   --  The Permission_Manager verifies through some policy that a permission
   --  is granted to a user.
   type Policy_Manager is new Ada.Finalization.Limited_Controlled with private;
   type Policy_Manager_Access is access all Policy_Manager'Class;

   --  Add the policy to the policy manager.  After a policy is added in the manager,
   --  it can participate in the security policy.
   procedure Add_Policy (Manager : in out Policy_Manager;
                         Policy  : in Policy_Access);

   --  Add a permission under the given permission name and associated with the controller.
   --  To verify the permission, the controller will be called.
   procedure Add_Permission (Manager    : in out Policy_Manager;
                             Name       : in String;
                             Permission : in Controller_Access);

   --  Get the security controller associated with the permission index Index.
   --  Returns null if there is no such controller.
   function Get_Controller (Manager : in Policy_Manager'Class;
                            Index   : in Permissions.Permission_Index) return Controller_Access;
   pragma Inline_Always (Get_Controller);

   --  Read the policy file
   procedure Read_Policy (Manager : in out Policy_Manager;
                          File    : in String);

   --  Initialize the permission manager.
   overriding
   procedure Initialize (Manager : in out Policy_Manager);

   --  Finalize the permission manager.
   overriding
   procedure Finalize (Manager : in out Policy_Manager);

   --  ------------------------------
   --  Policy Configuration
   --  ------------------------------
   type Policy_Config is record
      Id          : Natural := 0;
      Permissions : Util.Beans.Objects.Vectors.Vector;
      Patterns    : Util.Beans.Objects.Vectors.Vector;
      Manager     : Policy_Manager_Access;
   end record;
   type Policy_Config_Access is access all Policy_Config;

   --  Setup the XML parser to read the policy description.  For example:
   --
   --  <policy id='1'>
   --     <permission>create-workspace</permission>
   --     <permission>admin</permission>
   --     <url-pattern>/workspace/create</url-pattern>
   --     <url-pattern>/workspace/setup/*</url-pattern>
   --  </policy>
   --
   --  This policy gives access to the URL that match one of the URL pattern if the
   --  security context has the permission create-workspace or admin.
   generic
      Reader  : in out Util.Serialize.IO.XML.Parser;
      Manager : in Policy_Manager_Access;
   package Reader_Config is
      Config : aliased Policy_Config;
   end Reader_Config;

private

   use Util.Strings;

   subtype Permission_Index is Permissions.Permission_Index;

   type Permission_Type_Array is array (1 .. 10) of Permission_Type;

   type Permission_Index_Array is array (Positive range <>) of Permissions.Permission_Index;

   type Controller_Access_Array_Access is access all Controller_Access_Array;

   type Policy_Manager is new Ada.Finalization.Limited_Controlled with record
--        Cache        : Rules_Ref_Access;
--        Policies     : Policy_Vector.Vector;
      Permissions  : Controller_Access_Array_Access;
      Last_Index   : Permission_Index := Permission_Index'First;
   end record;

end Security.Policies;

Document Add_Permission

Document Add_Permission