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

   use type Ada.Real_Time.Time;

   procedure Free is
     new Ada.Unchecked_Deallocation (Object => Timer_Node,
                                     Name   => Timer_Node_Access);

   --  -----------------------
   --  Repeat the timer.
   --  -----------------------
   procedure Repeat (Event   : in out Timer_Ref;
                     In_Time : in Ada.Real_Time.Time_Span) is
      Timer : constant Timer_Node_Access := Event.Value;
   begin
      if Timer /= null and then Timer.List /= null then
         Timer.List.Add (Timer, Timer.Deadline + In_Time);
      end if;
   end Repeat;

   --  -----------------------
   --  Cancel the timer.
   --  -----------------------
   procedure Cancel (Event : in out Timer_Ref) is
   begin
      if Event.Value /= null and then Event.Value.List /= null then
         Event.Value.List.all.Cancel (Event.Value);
         Event.Value.List := null;
      end if;
   end Cancel;

   --  -----------------------
   --  Check if the timer is ready to be executed.
   --  -----------------------
   function Is_Scheduled (Event : in Timer_Ref) return Boolean is
   begin
      return Event.Value /= null and then Event.Value.List /= null;
   end Is_Scheduled;

   --  -----------------------
   --  Returns the deadline time for the timer execution.
   --  Returns Time'Last if the timer is not scheduled.
   --  -----------------------
   function Time_Of_Event (Event : in Timer_Ref) return Ada.Real_Time.Time is
   begin
      return (if Event.Value /= null then Event.Value.Deadline else Ada.Real_Time.Time_Last);
   end Time_Of_Event;

   --  -----------------------
   --  Set a timer to be called at the given time.
   --  -----------------------
   procedure Set_Timer (List    : in out Timer_List;
                        Handler : in Timer_Access;
                        Event   : in out Timer_Ref'Class;
                        At_Time : in Ada.Real_Time.Time) is
      Timer : Timer_Node_Access := Event.Value;
   begin
      if Timer = null then
         Event.Value := new Timer_Node;
         Timer := Event.Value;
      end if;
      Timer.Handler := Handler;

      --  Cancel the timer if it is part of another timer manager.
      if Timer.List /= null and Timer.List /= List.Manager'Unchecked_Access then
         Timer.List.Cancel (Timer);
      end if;

      --  Update the timer.
      Timer.List := List.Manager'Unchecked_Access;
      List.Manager.Add (Timer, At_Time);
   end Set_Timer;

   --  -----------------------
   --  Process the timer handlers that have passed the deadline and return the next
   --  deadline.  The <tt>Max_Count</tt> parameter allows to limit the number of timer handlers
   --  that are called by operation.  The default is not limited.
   --  -----------------------
   procedure Process (List      : in out Timer_List;
                      Timeout   : out Ada.Real_Time.Time;
                      Max_Count : in Natural := Natural'Last) is
      Timer : Timer_Ref;
      Now   : constant Ada.Real_Time.Time := Ada.Real_Time.Clock;
   begin
      loop
         List.Manager.Find_Next (Now, Timeout, Timer);
         exit when Timer.Value = null;
         Timer.Value.Handler.Time_Handler (Timer);
         Timer.Finalize;
      end loop;
   end Process;

   overriding
   procedure Adjust (Object : in out Timer_Ref) is
   begin
      if Object.Value /= null then
         Util.Concurrent.Counters.Increment (Object.Value.Counter);
      end if;
   end Adjust;

   overriding
   procedure Finalize (Object : in out Timer_Ref) is
      Is_Zero : Boolean;
   begin
      if Object.Value /= null then
         Util.Concurrent.Counters.Decrement (Object.Value.Counter, Is_Zero);
         if Is_Zero then
            Free (Object.Value);
         else
            Object.Value := null;
         end if;
      end if;
   end Finalize;

   protected body Timer_Manager is

      procedure Remove (Timer : in Timer_Node_Access) is
      begin
         if List = Timer then
            List := Timer.Next;
            Timer.Prev := null;
            if List /= null then
               List.Prev := null;
            end if;
         elsif Timer.Prev /= null then
            Timer.Prev.Next := Timer.Next;
            Timer.Next.Prev := Timer.Prev;
         else
            return;
         end if;
         Timer.Next := null;
         Timer.Prev := null;
         Timer.List := null;
      end Remove;

      --  -----------------------
      --  Add a timer.
      --  -----------------------
      procedure Add (Timer    : in Timer_Node_Access;
                     Deadline : in Ada.Real_Time.Time) is
         Current : Timer_Node_Access := List;
         Prev    : Timer_Node_Access;
      begin
         Util.Concurrent.Counters.Increment (Timer.Counter);
         if Timer.List /= null then
            Remove (Timer);
         end if;
         Timer.Deadline := Deadline;
         while Current /= null loop
            if Current.Deadline < Deadline then
               if Prev = null then
                  List := Timer;
               else
                  Prev.Next := Timer;
               end if;
               Timer.Next := Current;
               Current.Prev := Timer;
               return;
            end if;
            Prev := Current;
            Current := Current.Next;
         end loop;
         if Prev = null then
            List := Timer;
            Timer.Prev := null;
         else
            Prev.Next := Timer;
            Timer.Prev := Prev;
         end if;
         Timer.Next := null;
      end Add;

      --  -----------------------
      --  Cancel a timer.
      --  -----------------------
      procedure Cancel (Timer : in out Timer_Node_Access) is
         Is_Zero : Boolean;
      begin
         if Timer.List = null then
            return;
         end if;
         Remove (Timer);
         Util.Concurrent.Counters.Decrement (Timer.Counter, Is_Zero);
         if Is_Zero then
            Free (Timer);
         end if;
      end Cancel;

      --  -----------------------
      --  Find the next timer to be executed before the given time or return the next deadline.
      --  -----------------------
      procedure Find_Next (Before   : in Ada.Real_Time.Time;
                           Deadline : out Ada.Real_Time.Time;
                           Timer    : in out Timer_Ref) is
      begin
         if List = null then
            Deadline := Ada.Real_Time.Time_Last;
         elsif List.Deadline < Before then
            Timer.Value := List;
            List := List.Next;
            if List /= null then
               List.Prev := null;
               Deadline := List.Deadline;
            else
               Deadline := Ada.Real_Time.Time_Last;
            end if;
         else
            Deadline := List.Deadline;
         end if;
      end Find_Next;

   end Timer_Manager;

   overriding
   procedure Finalize (Object : in out Timer_List) is
      Timer    : Timer_Ref;
      Timeout  : Ada.Real_Time.Time;
   begin
      loop
         Object.Manager.Find_Next (Ada.Real_Time.Time_Last, Timeout, Timer);
         exit when Timer.Value = null;
         Timer.Finalize;
      end loop;
   end Finalize;

end Util.Events.Timers;

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

   use type Ada.Real_Time.Time;

   procedure Free is
     new Ada.Unchecked_Deallocation (Object => Timer_Node,
                                     Name   => Timer_Node_Access);

   --  -----------------------
   --  Repeat the timer.
   --  -----------------------
   procedure Repeat (Event   : in out Timer_Ref;
                     In_Time : in Ada.Real_Time.Time_Span) is
      Timer : constant Timer_Node_Access := Event.Value;
   begin
      if Timer /= null and then Timer.List /= null then
         Timer.List.Add (Timer, Timer.Deadline + In_Time);
      end if;
   end Repeat;

   --  -----------------------
   --  Cancel the timer.
   --  -----------------------
   procedure Cancel (Event : in out Timer_Ref) is
   begin
      if Event.Value /= null and then Event.Value.List /= null then
         Event.Value.List.all.Cancel (Event.Value);
         Event.Value.List := null;
      end if;
   end Cancel;

   --  -----------------------
   --  Check if the timer is ready to be executed.
   --  -----------------------
   function Is_Scheduled (Event : in Timer_Ref) return Boolean is
   begin
      return Event.Value /= null and then Event.Value.List /= null;
   end Is_Scheduled;

   --  -----------------------
   --  Returns the deadline time for the timer execution.
   --  Returns Time'Last if the timer is not scheduled.
   --  -----------------------
   function Time_Of_Event (Event : in Timer_Ref) return Ada.Real_Time.Time is
   begin
      return (if Event.Value /= null then Event.Value.Deadline else Ada.Real_Time.Time_Last);
   end Time_Of_Event;

   --  -----------------------
   --  Set a timer to be called at the given time.
   --  -----------------------
   procedure Set_Timer (List    : in out Timer_List;
                        Handler : in Timer_Access;
                        Event   : in out Timer_Ref'Class;
                        At_Time : in Ada.Real_Time.Time) is
      Timer : Timer_Node_Access := Event.Value;
   begin
      if Timer = null then
         Event.Value := new Timer_Node;
         Timer := Event.Value;
      end if;
      Timer.Handler := Handler;

      --  Cancel the timer if it is part of another timer manager.
      if Timer.List /= null and Timer.List /= List.Manager'Unchecked_Access then
         Timer.List.Cancel (Timer);
      end if;

      --  Update the timer.
      Timer.List := List.Manager'Unchecked_Access;
      List.Manager.Add (Timer, At_Time);
   end Set_Timer;

   --  -----------------------
   --  Set a timer to be called after the given time span.
   --  -----------------------
   procedure Set_Timer (List    : in out Timer_List;
                        Handler : in Timer_Access;
                        Event   : in out Timer_Ref'Class;
                        In_Time : in Ada.Real_Time.Time_Span) is
   begin
      List.Set_Timer (Handler, Event, Ada.Real_Time.Clock + In_Time);
   end Set_Timer;

   --  -----------------------
   --  Process the timer handlers that have passed the deadline and return the next
   --  deadline.  The <tt>Max_Count</tt> parameter allows to limit the number of timer handlers
   --  that are called by operation.  The default is not limited.
   --  -----------------------
   procedure Process (List      : in out Timer_List;
                      Timeout   : out Ada.Real_Time.Time;
                      Max_Count : in Natural := Natural'Last) is
      Timer : Timer_Ref;
      Now   : constant Ada.Real_Time.Time := Ada.Real_Time.Clock;
   begin
      loop
         List.Manager.Find_Next (Now, Timeout, Timer);
         exit when Timer.Value = null;
         Timer.Value.Handler.Time_Handler (Timer);
         Timer.Finalize;
      end loop;
   end Process;

   overriding
   procedure Adjust (Object : in out Timer_Ref) is
   begin
      if Object.Value /= null then
         Util.Concurrent.Counters.Increment (Object.Value.Counter);
      end if;
   end Adjust;

   overriding
   procedure Finalize (Object : in out Timer_Ref) is
      Is_Zero : Boolean;
   begin
      if Object.Value /= null then
         Util.Concurrent.Counters.Decrement (Object.Value.Counter, Is_Zero);
         if Is_Zero then
            Free (Object.Value);
         else
            Object.Value := null;
         end if;
      end if;
   end Finalize;

   protected body Timer_Manager is

      procedure Remove (Timer : in Timer_Node_Access) is
      begin
         if List = Timer then
            List := Timer.Next;
            Timer.Prev := null;
            if List /= null then
               List.Prev := null;
            end if;
         elsif Timer.Prev /= null then
            Timer.Prev.Next := Timer.Next;
            Timer.Next.Prev := Timer.Prev;
         else
            return;
         end if;
         Timer.Next := null;
         Timer.Prev := null;
         Timer.List := null;
      end Remove;

      --  -----------------------
      --  Add a timer.
      --  -----------------------
      procedure Add (Timer    : in Timer_Node_Access;
                     Deadline : in Ada.Real_Time.Time) is
         Current : Timer_Node_Access := List;
         Prev    : Timer_Node_Access;
      begin
         Util.Concurrent.Counters.Increment (Timer.Counter);
         if Timer.List /= null then
            Remove (Timer);
         end if;
         Timer.Deadline := Deadline;
         while Current /= null loop
            if Current.Deadline < Deadline then
               if Prev = null then
                  List := Timer;
               else
                  Prev.Next := Timer;
               end if;
               Timer.Next := Current;
               Current.Prev := Timer;
               return;
            end if;
            Prev := Current;
            Current := Current.Next;
         end loop;
         if Prev = null then
            List := Timer;
            Timer.Prev := null;
         else
            Prev.Next := Timer;
            Timer.Prev := Prev;
         end if;
         Timer.Next := null;
      end Add;

      --  -----------------------
      --  Cancel a timer.
      --  -----------------------
      procedure Cancel (Timer : in out Timer_Node_Access) is
         Is_Zero : Boolean;
      begin
         if Timer.List = null then
            return;
         end if;
         Remove (Timer);
         Util.Concurrent.Counters.Decrement (Timer.Counter, Is_Zero);
         if Is_Zero then
            Free (Timer);
         end if;
      end Cancel;

      --  -----------------------
      --  Find the next timer to be executed before the given time or return the next deadline.
      --  -----------------------
      procedure Find_Next (Before   : in Ada.Real_Time.Time;
                           Deadline : out Ada.Real_Time.Time;
                           Timer    : in out Timer_Ref) is
      begin
         if List = null then
            Deadline := Ada.Real_Time.Time_Last;
         elsif List.Deadline < Before then
            Timer.Value := List;
            List := List.Next;
            if List /= null then
               List.Prev := null;
               Deadline := List.Deadline;
            else
               Deadline := Ada.Real_Time.Time_Last;
            end if;
         else
            Deadline := List.Deadline;
         end if;
      end Find_Next;

   end Timer_Manager;

   overriding
   procedure Finalize (Object : in out Timer_List) is
      Timer    : Timer_Ref;
      Timeout  : Ada.Real_Time.Time;
   begin
      loop
         Object.Manager.Find_Next (Ada.Real_Time.Time_Last, Timeout, Timer);
         exit when Timer.Value = null;
         Timer.Finalize;
      end loop;
   end Finalize;

end Util.Events.Timers;

Implement the Set_Timer procedure which uses Time_Span as parameter


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

--  == Cached Stream ==
--  The <tt>Babel.Streams.Cached</tt> package provides a cached stream where the whole
--  stream is read in one or several stream buffers.
package Babel.Streams.Cached is

   type Stream_Type is new Babel.Streams.Stream_Type with private;
   type Stream_Access is access all Stream_Type'Class;

   --  Read the data stream as much as possible and return the result in a buffer.
   --  The buffer is owned by the stream and need not be released.  The same buffer may
   --  or may not be returned by the next <tt>Read</tt> operation.
   --  A null buffer is returned when the end of the data stream is reached.
   overriding
   procedure Read (Stream : in out Stream_Type;
                   Buffer : out Babel.Files.Buffers.Buffer_Access);

   --  Write the buffer in the data stream.
   overriding
   procedure Write (Stream : in out Stream_Type;
                    Buffer : in Babel.Files.Buffers.Buffer_Access);

   --  Flush the data stream.
   overriding
   procedure Flush (Stream : in out Stream_Type);

   --  Close the data stream.
   overriding
   procedure Close (Stream : in out Stream_Type);

   --  Prepare to read again the data stream from the beginning.
   overriding
   procedure Rewind (Stream : in out Stream_Type);

private

   type Stream_Type is new Babel.Streams.Stream_Type with record
      Input   : Babel.Streams.Stream_Access;
      Output  : Babel.Streams.Stream_Access;
      Buffers : Babel.Files.Buffers.Buffer_Access_Vector;
      Current : Babel.Files.Buffers.Buffer_Access_Cursor;
   end record;

end Babel.Streams.Cached;

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

--  == Cached Stream ==
--  The <tt>Babel.Streams.Cached</tt> package provides a cached stream where the whole
--  stream is read in one or several stream buffers.
package Babel.Streams.Cached is

   type Stream_Type is new Babel.Streams.Stream_Type with private;
   type Stream_Access is access all Stream_Type'Class;

   --  Load the file stream into the cache and use the buffer pool to obtain more buffers
   --  for the cache.
   procedure Load (Stream : in out Stream_Type;
                   File   : in out Babel.Streams.Stream_Type'Class;
                   Pool   : in out Babel.Files.Buffers.Buffer_Pool);

   --  Read the data stream as much as possible and return the result in a buffer.
   --  The buffer is owned by the stream and need not be released.  The same buffer may
   --  or may not be returned by the next <tt>Read</tt> operation.
   --  A null buffer is returned when the end of the data stream is reached.
   overriding
   procedure Read (Stream : in out Stream_Type;
                   Buffer : out Babel.Files.Buffers.Buffer_Access);

   --  Write the buffer in the data stream.
   overriding
   procedure Write (Stream : in out Stream_Type;
                    Buffer : in Babel.Files.Buffers.Buffer_Access);

   --  Prepare to read again the data stream from the beginning.
   overriding
   procedure Rewind (Stream : in out Stream_Type);

private

   type Stream_Type is new Babel.Streams.Stream_Type with record
      Input   : Babel.Streams.Stream_Access;
      Output  : Babel.Streams.Stream_Access;
      Buffers : Babel.Files.Buffers.Buffer_Access_Vector;
      Current : Babel.Files.Buffers.Buffer_Access_Cursor;
   end record;

   --  Release the buffers associated with the cache.
   overriding
   procedure Finalize (Stream : in out Stream_Type);

end Babel.Streams.Cached;

Define the Load and Finish procedures

Define the Load and Finish procedures


-----------------------------------------------------------------------
--  EL.Expressions -- Expression Nodes
--  Copyright (C) 2009, 2010 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.
-----------------------------------------------------------------------

--  The 'ELNode' describes an expression that can later be evaluated
--  on an expression context.  Expressions are parsed and translated
--  to a read-only tree.

with EL.Functions;
with Ada.Strings.Wide_Wide_Unbounded;
with Ada.Strings.Unbounded;
with Util.Concurrent.Counters;
private package EL.Expressions.Nodes is

   use EL.Functions;
   use Ada.Strings.Wide_Wide_Unbounded;
   use Ada.Strings.Unbounded;

   type Reduction;

   type ELNode is abstract tagged limited record
      Ref_Counter : Util.Concurrent.Counters.Counter;
   end record;

   type ELNode_Access is access all ELNode'Class;

   type Reduction is record
      Node  : ELNode_Access;
      Value : EL.Objects.Object;
   end record;

   --  Evaluate a node on a given context.
   function Get_Value (Expr    : ELNode;
                       Context : ELContext'Class) return Object is abstract;

   --  Reduce the expression by eliminating variables which are known
   --  and computing constant expressions.  Returns either a new expression
   --  tree or a constant value.
   function Reduce (Expr    : ELNode;
                    Context : ELContext'Class) return Reduction is abstract;

   --  Delete the expression tree (calls Delete (ELNode_Access) recursively).
   procedure Delete (Node : in out ELNode) is abstract;

   --  Delete the expression tree.  Free the memory allocated by nodes
   --  of the expression tree.  Clears the node pointer.
   procedure Delete (Node : in out ELNode_Access);

   --  ------------------------------
   --  Unary expression node
   --  ------------------------------
   type ELUnary is new ELNode with private;

   type Unary_Node is (EL_VOID, EL_NOT, EL_MINUS, EL_EMPTY);

   --  Evaluate a node on a given context.
   overriding
   function Get_Value (Expr    : ELUnary;
                       Context : ELContext'Class) return Object;

   --  Reduce the expression by eliminating variables which are known
   --  and computing constant expressions.  Returns either a new expression
   --  tree or a constant value.
   overriding
   function Reduce (Expr    : ELUnary;
                    Context : ELContext'Class) return Reduction;

   overriding
   procedure Delete (Node : in out ELUnary);

   --  ------------------------------
   --  Binary expression node
   --  ------------------------------
   type ELBinary is new ELNode with private;
   type Binary_Node is (EL_EQ, EL_NE, EL_LE, EL_LT, EL_GE, EL_GT,
                        EL_ADD, EL_SUB, EL_MUL, EL_DIV, EL_MOD,
                        EL_AND, EL_OR, EL_LAND, EL_LOR, EL_CONCAT);

   --  Evaluate a node on a given context.
   overriding
   function Get_Value (Expr    : ELBinary;
                       Context : ELContext'Class) return Object;

   --  Reduce the expression by eliminating variables which are known
   --  and computing constant expressions.  Returns either a new expression
   --  tree or a constant value.
   overriding
   function Reduce (Expr    : ELBinary;
                    Context : ELContext'Class) return Reduction;

   overriding
   procedure Delete (Node : in out ELBinary);

   --  ------------------------------
   --  Ternary expression node
   --  ------------------------------
   type ELTernary is new ELNode with private;

   --  Evaluate a node on a given context.
   overriding
   function Get_Value (Expr    : ELTernary;
                       Context : ELContext'Class) return Object;

   --  Reduce the expression by eliminating variables which are known
   --  and computing constant expressions.  Returns either a new expression
   --  tree or a constant value.
   overriding
   function Reduce (Expr    : ELTernary;
                    Context : ELContext'Class) return Reduction;

   overriding
   procedure Delete (Node : in out ELTernary);

   --  ------------------------------
   --  Variable to be looked at in the expression context
   --  ------------------------------
   type ELVariable is new ELNode with private;

   --  Evaluate a node on a given context.
   overriding
   function Get_Value (Expr    : ELVariable;
                       Context : ELContext'Class) return Object;

   --  Reduce the expression by eliminating variables which are known
   --  and computing constant expressions.  Returns either a new expression
   --  tree or a constant value.
   overriding
   function Reduce (Expr    : ELVariable;
                    Context : ELContext'Class) return Reduction;

   overriding
   procedure Delete (Node : in out ELVariable);

   --  ------------------------------
   --  Value property referring to a variable
   --  ------------------------------
   type ELValue is new ELNode with private;
   type ELValue_Access is access all ELValue'Class;

   --  Evaluate the node and return a method info with
   --  the bean object and the method binding.
   function Get_Method_Info (Node    : in ELValue;
                             Context : in ELContext'Class) return Method_Info;

   --  Evaluate a node on a given context.
   overriding
   function Get_Value (Expr    : ELValue;
                       Context : ELContext'Class) return Object;

   --  Reduce the expression by eliminating variables which are known
   --  and computing constant expressions.  Returns either a new expression
   --  tree or a constant value.
   overriding
   function Reduce (Expr    : ELValue;
                    Context : ELContext'Class) return Reduction;

   overriding
   procedure Delete (Node : in out ELValue);

   --  ------------------------------
   --  Literal object (integer, boolean, float, string)
   --  ------------------------------
   type ELObject is new ELNode with private;

   --  Evaluate a node on a given context.
   overriding
   function Get_Value (Expr    : ELObject;
                       Context : ELContext'Class) return Object;

   --  Reduce the expression by eliminating variables which are known
   --  and computing constant expressions.  Returns either a new expression
   --  tree or a constant value.
   overriding
   function Reduce (Expr    : ELObject;
                    Context : ELContext'Class) return Reduction;

   overriding
   procedure Delete (Node : in out ELObject);

   --  ------------------------------
   --  Function call with up to 4 arguments
   --  ------------------------------
   type ELFunction is new ELNode with private;

   --  Evaluate a node on a given context.
   overriding
   function Get_Value (Expr    : ELFunction;
                       Context : ELContext'Class) return Object;

   --  Reduce the expression by eliminating variables which are known
   --  and computing constant expressions.  Returns either a new expression
   --  tree or a constant value.
   overriding
   function Reduce (Expr    : ELFunction;
                    Context : ELContext'Class) return Reduction;

   overriding
   procedure Delete (Node : in out ELFunction);

   --  Create constant nodes
   function Create_Node (Value   : Boolean) return ELNode_Access;
   function Create_Node (Value   : Long_Long_Integer) return ELNode_Access;
   function Create_Node (Value   : String) return ELNode_Access;
   function Create_Node (Value   : Wide_Wide_String) return ELNode_Access;
   function Create_Node (Value   : Long_Float) return ELNode_Access;
   function Create_Node (Value : Unbounded_Wide_Wide_String) return ELNode_Access;
   function Create_Variable (Name : Unbounded_String) return ELNode_Access;
   function Create_Value (Variable : ELNode_Access;
                          Name     : Unbounded_String) return ELNode_Access;

   --  Create unary expressions
   function Create_Node (Of_Type : Unary_Node;
                         Expr    : ELNode_Access) return ELNode_Access;

   --  Create binary expressions
   function Create_Node (Of_Type : Binary_Node;
                         Left    : ELNode_Access;
                         Right   : ELNode_Access) return ELNode_Access;

   --  Create a ternary expression.
   function Create_Node (Cond  : ELNode_Access;
                         Left  : ELNode_Access;
                         Right : ELNode_Access) return ELNode_Access;

   --  Create a function call
   function Create_Node (Func  : EL.Functions.Function_Access;
                         Arg1  : ELNode_Access) return ELNode_Access;

   --  Create a function call
   function Create_Node (Func  : EL.Functions.Function_Access;
                         Arg1  : ELNode_Access;
                         Arg2  : ELNode_Access) return ELNode_Access;

   --  Create a function call
   function Create_Node (Func  : EL.Functions.Function_Access;
                         Arg1  : ELNode_Access;
                         Arg2  : ELNode_Access;
                         Arg3  : ELNode_Access) return ELNode_Access;

   --  Create a function call
   function Create_Node (Func  : EL.Functions.Function_Access;
                         Arg1  : ELNode_Access;
                         Arg2  : ELNode_Access;
                         Arg3  : ELNode_Access;
                         Arg4  : ELNode_Access) return ELNode_Access;

private

   type ELUnary is new ELNode with record
      Kind : Unary_Node;
      Node : ELNode_Access;
   end record;

   --  ------------------------------
   --  Binary nodes
   --  ------------------------------

   type ELBinary is new ELNode with record
      Kind  : Binary_Node;
      Left  : ELNode_Access;
      Right : ELNode_Access;
   end record;

   --  ------------------------------
   --  Ternary expression
   --  ------------------------------
   type ELTernary is new ELNode with record
      Cond  : ELNode_Access;
      Left  : ELNode_Access;
      Right : ELNode_Access;
   end record;

   --  #{bean.name}   - Bean name, Bean property
   --  #{bean[12]}    - Bean name,

   --  Variable to be looked at in the expression context
   type ELVariable is new ELNode with record
      Name     : Unbounded_String;
   end record;

   type ELValue is new ELNode with record
      Name     : Unbounded_String;
      Variable : ELNode_Access;
   end record;

   --  A literal object (integer, boolean, float, String)
   type ELObject is new ELNode with record
      Value : Object;
   end record;

   --  A function call with up to 4 arguments.
   type ELFunction is new ELNode with record
      Func : EL.Functions.Function_Access;
      Arg1 : ELNode_Access;
      Arg2 : ELNode_Access;
      Arg3 : ELNode_Access;
      Arg4 : ELNode_Access;
   end record;

end EL.Expressions.Nodes;

Fix indentation

Fix indentation


-----------------------------------------------------------------------
--  druss-commands-get -- Raw JSON API Get command
--  Copyright (C) 2017 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Text_IO;
with Ada.Containers;
with Bbox.API;
with Druss.Gateways;
package body Druss.Commands.Get is

   use type Ada.Containers.Count_Type;
   use Ada.Text_IO;
   use Ada.Strings.Unbounded;

   --  ------------------------------
   --  Execute a GET operation on the Bbox API and return the raw JSON result.
   --  ------------------------------
   overriding
   procedure Execute (Command   : in Command_Type;
                      Name      : in String;
                      Args      : in Argument_List'Class;
                      Context   : in out Context_Type) is
      pragma Unreferenced (Name);
      procedure Execute_One (Gateway : in out Druss.Gateways.Gateway_Type);

      Need_Colon : Boolean := False;

      --  Execute the GET API operation and print the raw JSON result.
      procedure Execute_One (Gateway : in out Druss.Gateways.Gateway_Type) is
         Box     : Bbox.API.Client_Type;
      begin
         Box.Set_Server (To_String (Gateway.Ip));
         if Ada.Strings.Unbounded.Length (Gateway.Passwd) > 0 then
            Box.Login (To_String (Gateway.Passwd));
         end if;
         for I in 1 .. Args.Get_Count loop
            declare
               Operation : constant String := Args.Get_Argument (I);
               Content   : constant String := Box.Get (Operation);
               Last      : Natural := Content'Last;
            begin
               if Need_Colon then
                  Ada.Text_IO.Put (",");
               end if;

               while Last > Content'First and Content (Last) = ASCII.LF loop
                  Last := Last - 1;
               end loop;

               --  We did a mistake when we designed the Bbox API and used '[' ... ']' arrays
               --  for most of the JSON result.  Strip that unecessary array.
               if Content (Content'First) = '[' and Content (Last) = ']' then
                  Ada.Text_IO.Put_Line (Content (Content'First + 1 .. Last - 1));
               else
                  Ada.Text_IO.Put_Line (Box.Get (Operation));
               end if;
               Need_Colon := True;
            end;
         end loop;
      end Execute_One;

   begin
      if Args.Get_Count = 0 then
         Druss.Commands.Driver.Usage (Args);
      else
         if Args.Get_Count > 1 or else Context.Gateways.Length > 1 then
            Ada.Text_IO.Put_Line ("[");
         end if;
         Druss.Gateways.Iterate (Context.Gateways, Execute_One'Access);
         if Args.Get_Count > 1 or else Context.Gateways.Length > 1 then
            Ada.Text_IO.Put_Line ("]");
         end if;
      end if;
   end Execute;

   --  ------------------------------
   --  Write the help associated with the command.
   --  ------------------------------
   overriding
   procedure Help (Command   : in Command_Type;
                   Context   : in out Context_Type) is
      pragma Unreferenced (Command, Context);
   begin
      Put_Line ("get: Execute one or several GET operation on the Bbox API" &
                  " and print the raw JSON result");
      Put_Line ("Usage: get <operation>...");
      New_Line;
      Put_Line ("  The Bbox API operation are called and the raw JSON result is printed.");
      Put_Line ("  When several operations are called, a JSON array is formed to insert");
      Put_Line ("  their result in the final JSON content so that it is valid.");
      Put_Line ("  Examples:");
      Put_Line ("    get device             Get information about the Bbox");
      Put_Line ("    get hosts              Get the list of hosts detected by the Bbox");
      Put_Line ("    get wan/ip             Get information about the WAN connection");
      Put_Line ("    get wan/ip wan/xdsl    Get the WAN connection and xDSL line information");
   end Help;

end Druss.Commands.Get;

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

   use type Ada.Containers.Count_Type;
   use Ada.Text_IO;
   use Ada.Strings.Unbounded;

   --  ------------------------------
   --  Execute a GET operation on the Bbox API and return the raw JSON result.
   --  ------------------------------
   overriding
   procedure Execute (Command   : in Command_Type;
                      Name      : in String;
                      Args      : in Argument_List'Class;
                      Context   : in out Context_Type) is
      pragma Unreferenced (Name);
      procedure Execute_One (Gateway : in out Druss.Gateways.Gateway_Type);

      Need_Colon : Boolean := False;

      --  Execute the GET API operation and print the raw JSON result.
      procedure Execute_One (Gateway : in out Druss.Gateways.Gateway_Type) is
         Box     : Bbox.API.Client_Type;
      begin
         Box.Set_Server (To_String (Gateway.Ip));
         if Ada.Strings.Unbounded.Length (Gateway.Passwd) > 0 then
            Box.Login (To_String (Gateway.Passwd));
         end if;
         for I in 1 .. Args.Get_Count loop
            declare
               Operation : constant String := Args.Get_Argument (I);
               Content   : constant String := Box.Get (Operation);
               Last      : Natural := Content'Last;
            begin
               if Need_Colon then
                  Ada.Text_IO.Put (",");
               end if;

               while Last > Content'First and Content (Last) = ASCII.LF loop
                  Last := Last - 1;
               end loop;

               --  We did a mistake when we designed the Bbox API and used '[' ... ']' arrays
               --  for most of the JSON result.  Strip that unecessary array.
               if Content (Content'First) = '[' and Content (Last) = ']' then
                  Ada.Text_IO.Put_Line (Content (Content'First + 1 .. Last - 1));
               else
                  Ada.Text_IO.Put_Line (Box.Get (Operation));
               end if;
               Need_Colon := True;
            end;
         end loop;
      end Execute_One;

   begin
      if Args.Get_Count = 0 then
         Druss.Commands.Driver.Usage (Args);
      else
         if Args.Get_Count > 1 or else Context.Gateways.Length > 1 then
            Ada.Text_IO.Put_Line ("[");
         end if;
         Druss.Gateways.Iterate (Context.Gateways, Execute_One'Access);
         if Args.Get_Count > 1 or else Context.Gateways.Length > 1 then
            Ada.Text_IO.Put_Line ("]");
         end if;
      end if;
   end Execute;

   --  ------------------------------
   --  Write the help associated with the command.
   --  ------------------------------
   overriding
   procedure Help (Command   : in Command_Type;
                   Context   : in out Context_Type) is
      pragma Unreferenced (Command, Context);
   begin
      Put_Line ("get: Execute one or several GET operation on the Bbox API" &
                  " and print the raw JSON result");
      Put_Line ("Usage: get <operation>...");
      New_Line;
      Put_Line ("  The Bbox API operation are called and the raw JSON result is printed.");
      Put_Line ("  When several operations are called, a JSON array is formed to insert");
      Put_Line ("  their result in the final JSON content so that it is valid.");
      Put_Line ("  Examples:");
      Put_Line ("    get device             Get information about the Bbox");
      Put_Line ("    get hosts              Get the list of hosts detected by the Bbox");
      Put_Line ("    get wan/ip             Get information about the WAN connection");
      Put_Line ("    get wan/ip wan/xdsl    Get the WAN connection and xDSL line information");
   end Help;

end Druss.Commands.Get;

Add with clause Ada.Strings.Unbounded

Add with clause Ada.Strings.Unbounded


------------------------------------------------------------------------------
-- Copyright (c) 2016, 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.           --
------------------------------------------------------------------------------

package body Natools.Smaz_Generic is

   use type Ada.Streams.Stream_Element_Offset;

   procedure Find_Entry
     (Dict : in Dictionary;
      Template : in String;
      Code : out Dictionary_Code;
      Length : out Natural);
      --  Try to find the longest entry in Dict that is a prefix of Template,
      --  setting Length to 0 when no such entry exists.

   function Verbatim_Size
     (Dict : in Dictionary;
      Length : in Positive)
     return Ada.Streams.Stream_Element_Count
   is (Verbatim_Size (Length, Dict.Last_Code, Dict.Variable_Length_Verbatim));
      --  Wrapper around the formal Verbatim_Size

   ------------------------------
   -- Local Helper Subprograms --
   ------------------------------

   procedure Find_Entry
     (Dict : in Dictionary;
      Template : in String;
      Code : out Dictionary_Code;
      Length : out Natural)
   is
      N : Natural;
      Is_Valid : Boolean;
   begin
      Length := 0;

      for Last in reverse Template'Range loop
         Is_Valid := False;
         N := Dict.Hash (Template (Template'First .. Last));

         To_Code :
         begin
            Code := Dictionary_Code'Val (N);
            if Is_Valid_Code (Dict, Code) then
               Is_Valid := True;
            end if;
         exception
            when Constraint_Error => null;
         end To_Code;

         if Is_Valid
           and then Dict_Entry (Dict, Code) = Template (Template'First .. Last)
         then
            Length := 1 + Last - Template'First;
            return;
         end if;
      end loop;
   end Find_Entry;

   ----------------------
   -- Public Interface --
   ----------------------

   function Compressed_Upper_Bound
     (Dict : in Dictionary;
      Input : in String)
     return Ada.Streams.Stream_Element_Count is
   begin
      return Verbatim_Size
        (Input'Length, Dict.Last_Code, Dict.Variable_Length_Verbatim);
   end Compressed_Upper_Bound;

   procedure Compress
     (Dict : in Dictionary;
      Input : in String;
      Output_Buffer : out Ada.Streams.Stream_Element_Array;
      Output_Last : out Ada.Streams.Stream_Element_Offset)
   is
      procedure Find_Current_Entry;

      Input_Index : Positive := Input'First;
      Length : Natural;
      Code : Dictionary_Code;
      Output_Index : Ada.Streams.Stream_Element_Offset;

      procedure Find_Current_Entry is
      begin
         Find_Entry
           (Dict,
            Input (Input_Index
                   .. Natural'Min (Input_Index + Dict.Max_Word_Length - 1,
                                   Input'Last)),
            Code,
            Length);
      end Find_Current_Entry;

      Previous_Verbatim_Beginning : Natural := 0;
      Previous_Verbatim_Index : Ada.Streams.Stream_Element_Offset := 0;
   begin
      Output_Index := Output_Buffer'First;
      Find_Current_Entry;

      Main_Loop :
      while Input_Index in Input'Range loop
         Data_In_Dict :
         while Length > 0 loop
            Write_Code (Output_Buffer, Output_Index, Code);
            Input_Index := Input_Index + Length;
            exit Main_Loop when Input_Index not in Input'Range;
            Find_Current_Entry;
         end loop Data_In_Dict;

         Verbatim_Block :
         declare
            Beginning : Positive := Input_Index;
            Verbatim_Length : Natural;
         begin
            Verbatim_Scan :
            while Length = 0 and Input_Index in Input'Range loop
               Input_Index := Input_Index + 1;
               Find_Current_Entry;
            end loop Verbatim_Scan;

            Verbatim_Length := Input_Index - Beginning;

            if Previous_Verbatim_Beginning > 0
              and then Output_Index + Verbatim_Size (Dict, Verbatim_Length)
                 >= Previous_Verbatim_Index + Verbatim_Size
                    (Dict, Input_Index - Previous_Verbatim_Beginning)
            then
               Beginning := Previous_Verbatim_Beginning;
               Output_Index := Previous_Verbatim_Index;
               Verbatim_Length := Input_Index - Beginning;
            else
               Previous_Verbatim_Beginning := Beginning;
               Previous_Verbatim_Index := Output_Index;
            end if;

            Write_Verbatim
              (Output_Buffer, Output_Index,
               Input (Beginning .. Input_Index - 1),
               Dict.Last_Code, Dict.Variable_Length_Verbatim);
         end Verbatim_Block;
      end loop Main_Loop;

      Output_Last := Output_Index - 1;
   end Compress;

   function Compress (Dict : in Dictionary; Input : in String)
     return Ada.Streams.Stream_Element_Array
   is
      Result : Ada.Streams.Stream_Element_Array
        (1 .. Compressed_Upper_Bound (Dict, Input));
      Last : Ada.Streams.Stream_Element_Offset;
   begin
      Compress (Dict, Input, Result, Last);
      return Result (Result'First .. Last);
   end Compress;

   function Decompressed_Length
     (Dict : in Dictionary;
      Input : in Ada.Streams.Stream_Element_Array)
     return Natural
   is
      Result : Natural := 0;
      Input_Index : Ada.Streams.Stream_Element_Offset := Input'First;
      Code : Dictionary_Code;
      Verbatim_Length : Natural;
   begin
      while Input_Index in Input'Range loop
         Read_Code
           (Input, Input_Index,
            Code, Verbatim_Length,
            Dict.Last_Code, Dict.Variable_Length_Verbatim);

         if Verbatim_Length > 0 then
            Skip_Verbatim (Input, Input_Index, Verbatim_Length);
            Result := Result + Verbatim_Length;
         else
            Result := Result + Dict_Entry_Length (Dict, Code);
         end if;
      end loop;

      return Result;
   end Decompressed_Length;

   procedure Decompress
     (Dict : in Dictionary;
      Input : in Ada.Streams.Stream_Element_Array;
      Output_Buffer : out String;
      Output_Last : out Natural)
   is
      Input_Index : Ada.Streams.Stream_Element_Offset := Input'First;
      Code : Dictionary_Code;
      Verbatim_Length : Natural;
   begin
      Output_Last := Output_Buffer'First - 1;

      while Input_Index in Input'Range loop
         Read_Code
           (Input, Input_Index,
            Code, Verbatim_Length,
            Dict.Last_Code, Dict.Variable_Length_Verbatim);

         if Verbatim_Length > 0 then
            Read_Verbatim
              (Input, Input_Index,
               Output_Buffer
                 (Output_Last + 1 .. Output_Last + Verbatim_Length));
            Output_Last := Output_Last + Verbatim_Length;
         else
            declare
               Decoded : constant String := Dict_Entry (Dict, Code);
            begin
               Output_Buffer (Output_Last + 1 .. Output_Last + Decoded'Length)
                 := Decoded;
               Output_Last := Output_Last + Decoded'Length;
            end;
         end if;
      end loop;
   end Decompress;

   function Decompress
     (Dict : in Dictionary; Input : in Ada.Streams.Stream_Element_Array)
     return String
   is
      Result : String (1 .. Decompressed_Length (Dict, Input));
      Last : Natural;
   begin
      Decompress (Dict, Input, Result, Last);
      pragma Assert (Last = Result'Last);
      return Result;
   end Decompress;

end Natools.Smaz_Generic;

------------------------------------------------------------------------------
-- Copyright (c) 2016, 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.           --
------------------------------------------------------------------------------

package body Natools.Smaz_Generic is

   use type Ada.Streams.Stream_Element_Offset;

   procedure Find_Entry
     (Dict : in Dictionary;
      Template : in String;
      Code : out Dictionary_Code;
      Length : out Natural);
      --  Try to find the longest entry in Dict that is a prefix of Template,
      --  setting Length to 0 when no such entry exists.

   function Verbatim_Size
     (Dict : in Dictionary;
      Length : in Positive)
     return Ada.Streams.Stream_Element_Count
   is (Verbatim_Size (Length, Dict.Last_Code, Dict.Variable_Length_Verbatim));
      --  Wrapper around the formal Verbatim_Size

   ------------------------------
   -- Local Helper Subprograms --
   ------------------------------

   procedure Find_Entry
     (Dict : in Dictionary;
      Template : in String;
      Code : out Dictionary_Code;
      Length : out Natural)
   is
      N : Natural;
      Is_Valid : Boolean;
   begin
      Length := 0;

      for Last in reverse Template'Range loop
         Is_Valid := False;
         N := Dict.Hash (Template (Template'First .. Last));

         To_Code :
         begin
            Code := Dictionary_Code'Val (N);
            if Is_Valid_Code (Dict, Code) then
               Is_Valid := True;
            end if;
         exception
            when Constraint_Error => null;
         end To_Code;

         if Is_Valid
           and then Template (Template'First .. Last)
              = Dict.Values (Code_First (Dict.Offsets, Code, Dict.Values'First)
                          .. Code_Last (Dict.Offsets, Code, Dict.Values'Last))
         then
            Length := 1 + Last - Template'First;
            return;
         end if;
      end loop;
   end Find_Entry;

   ----------------------
   -- Public Interface --
   ----------------------

   function Compressed_Upper_Bound
     (Dict : in Dictionary;
      Input : in String)
     return Ada.Streams.Stream_Element_Count is
   begin
      return Verbatim_Size
        (Input'Length, Dict.Last_Code, Dict.Variable_Length_Verbatim);
   end Compressed_Upper_Bound;

   procedure Compress
     (Dict : in Dictionary;
      Input : in String;
      Output_Buffer : out Ada.Streams.Stream_Element_Array;
      Output_Last : out Ada.Streams.Stream_Element_Offset)
   is
      procedure Find_Current_Entry;

      Input_Index : Positive := Input'First;
      Length : Natural;
      Code : Dictionary_Code;
      Output_Index : Ada.Streams.Stream_Element_Offset;

      procedure Find_Current_Entry is
      begin
         Find_Entry
           (Dict,
            Input (Input_Index
                   .. Natural'Min (Input_Index + Dict.Max_Word_Length - 1,
                                   Input'Last)),
            Code,
            Length);
      end Find_Current_Entry;

      Previous_Verbatim_Beginning : Natural := 0;
      Previous_Verbatim_Index : Ada.Streams.Stream_Element_Offset := 0;
   begin
      Output_Index := Output_Buffer'First;
      Find_Current_Entry;

      Main_Loop :
      while Input_Index in Input'Range loop
         Data_In_Dict :
         while Length > 0 loop
            Write_Code (Output_Buffer, Output_Index, Code);
            Input_Index := Input_Index + Length;
            exit Main_Loop when Input_Index not in Input'Range;
            Find_Current_Entry;
         end loop Data_In_Dict;

         Verbatim_Block :
         declare
            Beginning : Positive := Input_Index;
            Verbatim_Length : Natural;
         begin
            Verbatim_Scan :
            while Length = 0 and Input_Index in Input'Range loop
               Input_Index := Input_Index + 1;
               Find_Current_Entry;
            end loop Verbatim_Scan;

            Verbatim_Length := Input_Index - Beginning;

            if Previous_Verbatim_Beginning > 0
              and then Output_Index + Verbatim_Size (Dict, Verbatim_Length)
                 >= Previous_Verbatim_Index + Verbatim_Size
                    (Dict, Input_Index - Previous_Verbatim_Beginning)
            then
               Beginning := Previous_Verbatim_Beginning;
               Output_Index := Previous_Verbatim_Index;
               Verbatim_Length := Input_Index - Beginning;
            else
               Previous_Verbatim_Beginning := Beginning;
               Previous_Verbatim_Index := Output_Index;
            end if;

            Write_Verbatim
              (Output_Buffer, Output_Index,
               Input (Beginning .. Input_Index - 1),
               Dict.Last_Code, Dict.Variable_Length_Verbatim);
         end Verbatim_Block;
      end loop Main_Loop;

      Output_Last := Output_Index - 1;
   end Compress;

   function Compress (Dict : in Dictionary; Input : in String)
     return Ada.Streams.Stream_Element_Array
   is
      Result : Ada.Streams.Stream_Element_Array
        (1 .. Compressed_Upper_Bound (Dict, Input));
      Last : Ada.Streams.Stream_Element_Offset;
   begin
      Compress (Dict, Input, Result, Last);
      return Result (Result'First .. Last);
   end Compress;

   function Decompressed_Length
     (Dict : in Dictionary;
      Input : in Ada.Streams.Stream_Element_Array)
     return Natural
   is
      Result : Natural := 0;
      Input_Index : Ada.Streams.Stream_Element_Offset := Input'First;
      Code : Dictionary_Code;
      Verbatim_Length : Natural;
   begin
      while Input_Index in Input'Range loop
         Read_Code
           (Input, Input_Index,
            Code, Verbatim_Length,
            Dict.Last_Code, Dict.Variable_Length_Verbatim);

         if Verbatim_Length > 0 then
            Skip_Verbatim (Input, Input_Index, Verbatim_Length);
            Result := Result + Verbatim_Length;
         else
            Result := Result + Dict_Entry_Length (Dict, Code);
         end if;
      end loop;

      return Result;
   end Decompressed_Length;

   procedure Decompress
     (Dict : in Dictionary;
      Input : in Ada.Streams.Stream_Element_Array;
      Output_Buffer : out String;
      Output_Last : out Natural)
   is
      Input_Index : Ada.Streams.Stream_Element_Offset := Input'First;
      Code : Dictionary_Code;
      Verbatim_Length : Natural;
   begin
      Output_Last := Output_Buffer'First - 1;

      while Input_Index in Input'Range loop
         Read_Code
           (Input, Input_Index,
            Code, Verbatim_Length,
            Dict.Last_Code, Dict.Variable_Length_Verbatim);

         if Verbatim_Length > 0 then
            Read_Verbatim
              (Input, Input_Index,
               Output_Buffer
                 (Output_Last + 1 .. Output_Last + Verbatim_Length));
            Output_Last := Output_Last + Verbatim_Length;
         else
            declare
               Decoded : constant String := Dict_Entry (Dict, Code);
            begin
               Output_Buffer (Output_Last + 1 .. Output_Last + Decoded'Length)
                 := Decoded;
               Output_Last := Output_Last + Decoded'Length;
            end;
         end if;
      end loop;
   end Decompress;

   function Decompress
     (Dict : in Dictionary; Input : in Ada.Streams.Stream_Element_Array)
     return String
   is
      Result : String (1 .. Decompressed_Length (Dict, Input));
      Last : Natural;
   begin
      Decompress (Dict, Input, Result, Last);
      pragma Assert (Last = Result'Last);
      return Result;
   end Decompress;

end Natools.Smaz_Generic;

optimize compression

smaz_generic: optimize compression

For some reason it seems even with -O3, calling Dict_Entry involves a
string copy, which makes `memcpy` the larger time consumer of the
copmpression algorithm. Inlining it manually improves performance a lot.


-----------------------------------------------------------------------
--  security-contexts -- Context to provide security information and verify permissions
--  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.Task_Attributes;

with Security.Controllers;
package body Security.Contexts is

   package Task_Context is new Ada.Task_Attributes
     (Security_Context_Access, null);

   --  ------------------------------
   --  Get the application associated with the current service operation.
   --  ------------------------------
   function Get_User_Principal (Context : in Security_Context'Class)
                                return Security.Principal_Access is
   begin
      return Context.Principal;
   end Get_User_Principal;

   --  ------------------------------
   --  Get the permission manager.
   --  ------------------------------
   function Get_Permission_Manager (Context : in Security_Context'Class)
                                    return Security.Policies.Policy_Manager_Access is
   begin
      return Context.Manager;
   end Get_Permission_Manager;

   --  ------------------------------
   --  Check if the permission identified by Permission is allowed according to
   --  the current security context.  The result is cached in the security context and
   --  returned in Result.
   --  ------------------------------
   procedure Has_Permission (Context    : in out Security_Context;
                             Permission : in Security.Permissions.Permission_Index;
                             Result     : out Boolean) is
      use type Security.Policies.Controller_Access;
      use type Security.Policies.Policy_Manager_Access;
   begin
      if Context.Manager = null then
         Result := False;
         return;
      end if;
      declare
         C : constant Policies.Controller_Access := Context.Manager.Get_Controller (Permission);
      begin
         if C = null then
            Result := False;
         else
            --              Result := C.Has_Permission (Context);
            Result := False;
         end if;
      end;
   end Has_Permission;

   --  ------------------------------
   --  Check if the permission identified by Permission is allowed according to
   --  the current security context.  The result is cached in the security context and
   --  returned in Result.
   --  ------------------------------
   procedure Has_Permission (Context    : in out Security_Context;
                             Permission : in String;
                             Result     : out Boolean) is
      Index : constant Permissions.Permission_Index
        := Permissions.Get_Permission_Index (Permission);
   begin
      Security_Context'Class (Context).Has_Permission (Index, Result);
   end Has_Permission;

   --  ------------------------------
   --  Initializes the service context.  By creating the Security_Context variable,
   --  the instance will be associated with the current task attribute.  If the current task
   --  already has a security context, the new security context is installed, the old one
   --  being kept.
   --  ------------------------------
   overriding
   procedure Initialize (Context : in out Security_Context) is
   begin
      Context.Previous := Task_Context.Value;
      Task_Context.Set_Value (Context'Unchecked_Access);
   end Initialize;

   --  ------------------------------
   --  Finalize the security context releases any object.  The previous security context is
   --  restored to the current task attribute.
   --  ------------------------------
   overriding
   procedure Finalize (Context : in out Security_Context) is
   begin
      Task_Context.Set_Value (Context.Previous);
   end Finalize;

   --  ------------------------------
   --  Add a context information represented by Value under the name identified by
   --  Name in the security context Context.
   --  ------------------------------
   procedure Add_Context (Context   : in out Security_Context;
                          Name      : in String;
                          Value     : in String) is
   begin
      Context.Context.Include (Key      => Name,
                               New_Item => Value);
   end Add_Context;

   --  ------------------------------
   --  Get the context information registered under the name Name in the security
   --  context Context.
   --  Raises Invalid_Context if there is no such information.
   --  ------------------------------
   function Get_Context (Context  : in Security_Context;
                         Name     : in String) return String is
      Pos : constant Util.Strings.Maps.Cursor := Context.Context.Find (Name);
   begin
      if Util.Strings.Maps.Has_Element (Pos) then
         return Util.Strings.Maps.Element (Pos);
      else
         raise Invalid_Context;
      end if;
   end Get_Context;

   --  ------------------------------
   --  Returns True if a context information was registered under the name Name.
   --  ------------------------------
   function Has_Context (Context : in Security_Context;
                         Name    : in String) return Boolean is
      use type Util.Strings.Maps.Cursor;
   begin
      return Context.Context.Find (Name) /= Util.Strings.Maps.No_Element;
   end Has_Context;

   --  ------------------------------
   --  Set the current application and user context.
   --  ------------------------------
   procedure Set_Context (Context   : in out Security_Context;
                          Manager   : in Security.Policies.Policy_Manager_Access;
                          Principal : in Security.Principal_Access) is
   begin
      Context.Manager   := Manager;
      Context.Principal := Principal;
   end Set_Context;

   --  ------------------------------
   --  Get the current security context.
   --  Returns null if the current thread is not associated with any security context.
   --  ------------------------------
   function Current return Security_Context_Access is
   begin
      return Task_Context.Value;
   end Current;

   --  ------------------------------
   --  Check if the permission identified by Permission is allowed according to
   --  the current security context.  The result is cached in the security context and
   --  returned in Result.
   --  ------------------------------
   function Has_Permission (Permission : in Permissions.Permission_Index) return Boolean is
      Result  : Boolean;
      Context : constant Security_Context_Access := Current;
   begin
      if Context = null then
         return False;
      else
         Context.Has_Permission (Permission, Result);
         return Result;
      end if;
   end Has_Permission;

   --  ------------------------------
   --  Check if the permission identified by Permission is allowed according to
   --  the current security context.  The result is cached in the security context and
   --  returned in Result.
   --  ------------------------------
   function Has_Permission (Permission : in String) return Boolean is
      Result  : Boolean;
      Context : constant Security_Context_Access := Current;
   begin
      if Context = null then
         return False;
      else
         Context.Has_Permission (Permission, Result);
         return Result;
      end if;
   end Has_Permission;

end Security.Contexts;

-----------------------------------------------------------------------
--  security-contexts -- Context to provide security information and verify permissions
--  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.Task_Attributes;

package body Security.Contexts is

   package Task_Context is new Ada.Task_Attributes
     (Security_Context_Access, null);

   --  ------------------------------
   --  Get the application associated with the current service operation.
   --  ------------------------------
   function Get_User_Principal (Context : in Security_Context'Class)
                                return Security.Principal_Access is
   begin
      return Context.Principal;
   end Get_User_Principal;

   --  ------------------------------
   --  Get the permission manager.
   --  ------------------------------
   function Get_Permission_Manager (Context : in Security_Context'Class)
                                    return Security.Policies.Policy_Manager_Access is
   begin
      return Context.Manager;
   end Get_Permission_Manager;

   --  ------------------------------
   --  Check if the permission identified by Permission is allowed according to
   --  the current security context.  The result is cached in the security context and
   --  returned in Result.
   --  ------------------------------
   procedure Has_Permission (Context    : in out Security_Context;
                             Permission : in Security.Permissions.Permission_Index;
                             Result     : out Boolean) is
      use type Security.Policies.Controller_Access;
      use type Security.Policies.Policy_Manager_Access;
   begin
      if Context.Manager = null then
         Result := False;
         return;
      end if;
      declare
         C : constant Policies.Controller_Access := Context.Manager.Get_Controller (Permission);
      begin
         if C = null then
            Result := False;
         else
            --              Result := C.Has_Permission (Context);
            Result := False;
         end if;
      end;
   end Has_Permission;

   --  ------------------------------
   --  Check if the permission identified by Permission is allowed according to
   --  the current security context.  The result is cached in the security context and
   --  returned in Result.
   --  ------------------------------
   procedure Has_Permission (Context    : in out Security_Context;
                             Permission : in String;
                             Result     : out Boolean) is
      Index : constant Permissions.Permission_Index
        := Permissions.Get_Permission_Index (Permission);
   begin
      Security_Context'Class (Context).Has_Permission (Index, Result);
   end Has_Permission;

   --  ------------------------------
   --  Initializes the service context.  By creating the Security_Context variable,
   --  the instance will be associated with the current task attribute.  If the current task
   --  already has a security context, the new security context is installed, the old one
   --  being kept.
   --  ------------------------------
   overriding
   procedure Initialize (Context : in out Security_Context) is
   begin
      Context.Previous := Task_Context.Value;
      Task_Context.Set_Value (Context'Unchecked_Access);
   end Initialize;

   --  ------------------------------
   --  Finalize the security context releases any object.  The previous security context is
   --  restored to the current task attribute.
   --  ------------------------------
   overriding
   procedure Finalize (Context : in out Security_Context) is
   begin
      Task_Context.Set_Value (Context.Previous);
   end Finalize;

   --  ------------------------------
   --  Add a context information represented by Value under the name identified by
   --  Name in the security context Context.
   --  ------------------------------
   procedure Add_Context (Context   : in out Security_Context;
                          Name      : in String;
                          Value     : in String) is
   begin
      Context.Context.Include (Key      => Name,
                               New_Item => Value);
   end Add_Context;

   --  ------------------------------
   --  Get the context information registered under the name Name in the security
   --  context Context.
   --  Raises Invalid_Context if there is no such information.
   --  ------------------------------
   function Get_Context (Context  : in Security_Context;
                         Name     : in String) return String is
      Pos : constant Util.Strings.Maps.Cursor := Context.Context.Find (Name);
   begin
      if Util.Strings.Maps.Has_Element (Pos) then
         return Util.Strings.Maps.Element (Pos);
      else
         raise Invalid_Context;
      end if;
   end Get_Context;

   --  ------------------------------
   --  Returns True if a context information was registered under the name Name.
   --  ------------------------------
   function Has_Context (Context : in Security_Context;
                         Name    : in String) return Boolean is
      use type Util.Strings.Maps.Cursor;
   begin
      return Context.Context.Find (Name) /= Util.Strings.Maps.No_Element;
   end Has_Context;

   --  ------------------------------
   --  Set the current application and user context.
   --  ------------------------------
   procedure Set_Context (Context   : in out Security_Context;
                          Manager   : in Security.Policies.Policy_Manager_Access;
                          Principal : in Security.Principal_Access) is
   begin
      Context.Manager   := Manager;
      Context.Principal := Principal;
   end Set_Context;

   --  ------------------------------
   --  Get the current security context.
   --  Returns null if the current thread is not associated with any security context.
   --  ------------------------------
   function Current return Security_Context_Access is
   begin
      return Task_Context.Value;
   end Current;

   --  ------------------------------
   --  Check if the permission identified by Permission is allowed according to
   --  the current security context.  The result is cached in the security context and
   --  returned in Result.
   --  ------------------------------
   function Has_Permission (Permission : in Permissions.Permission_Index) return Boolean is
      Result  : Boolean;
      Context : constant Security_Context_Access := Current;
   begin
      if Context = null then
         return False;
      else
         Context.Has_Permission (Permission, Result);
         return Result;
      end if;
   end Has_Permission;

   --  ------------------------------
   --  Check if the permission identified by Permission is allowed according to
   --  the current security context.  The result is cached in the security context and
   --  returned in Result.
   --  ------------------------------
   function Has_Permission (Permission : in String) return Boolean is
      Result  : Boolean;
      Context : constant Security_Context_Access := Current;
   begin
      if Context = null then
         return False;
      else
         Context.Has_Permission (Permission, Result);
         return Result;
      end if;
   end Has_Permission;

end Security.Contexts;

Remove unused with clause

Remove unused with clause


-----------------------------------------------------------------------
--  security-contexts -- Context to provide security information and verify permissions
--  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.Finalization;

with Util.Strings.Maps;
with Security.Permissions;

--  == Security Context ==
--  The security context provides contextual information for a security controller to
--  verify that a permission is granted.
--  This security context is used as follows:
--
--    * An instance of the security context is declared within a function/procedure as
--      a local variable
--
--    * This instance will be associated with the current thread through a task attribute
--
--    * The security context is populated with information to identify the current user,
--      his roles, permissions and other information that could be used by security controllers
--
--    * To verify a permission, the current security context is retrieved and the
--      Has_Permission operation is called,
--
--    * The Has_Permission will first look in a small cache stored in the security context.
--
--    * When not present in the cache, it will use the security manager to find the
--      security controller associated with the permission to verify
--
--    * The security controller will be called with the security context to check the permission.
--      The whole job of checking the permission is done by the security controller.
--      The security controller retrieves information from the security context to decide
--      whether the permission is granted or not.
--
--    * The result produced by the security controller is then saved in the local cache.
--
package Security.Contexts is

   Invalid_Context : exception;

   type Security_Context is new Ada.Finalization.Limited_Controlled with private;
   type Security_Context_Access is access all Security_Context'Class;

   --  Get the application associated with the current service operation.
   function Get_User_Principal (Context : in Security_Context'Class)
                                return Security.Principal_Access;
   pragma Inline_Always (Get_User_Principal);

   --  Get the permission manager.
   function Get_Permission_Manager (Context : in Security_Context'Class)
                                    return Security.Permissions.Permission_Manager_Access;
   pragma Inline_Always (Get_Permission_Manager);

   --  Check if the permission identified by Permission is allowed according to
   --  the current security context.  The result is cached in the security context and
   --  returned in Result.
   procedure Has_Permission (Context    : in out Security_Context;
                             Permission : in Security.Permissions.Permission_Index;
                             Result     : out Boolean);

   --  Check if the permission identified by Permission is allowed according to
   --  the current security context.  The result is cached in the security context and
   --  returned in Result.
   procedure Has_Permission (Context    : in out Security_Context;
                             Permission : in String;
                             Result     : out Boolean);

   --  Initializes the service context.  By creating the Security_Context variable,
   --  the instance will be associated with the current task attribute.  If the current task
   --  already has a security context, the new security context is installed, the old one
   --  being kept.
   overriding
   procedure Initialize (Context : in out Security_Context);

   --  Finalize the security context releases any object.  The previous security context is
   --  restored to the current task attribute.
   overriding
   procedure Finalize (Context : in out Security_Context);

   --  Set the current application and user context.
   procedure Set_Context (Context   : in out Security_Context;
                          Manager   : in Security.Permissions.Permission_Manager_Access;
                          Principal : in Security.Principal_Access);

   --  Add a context information represented by Value under the name identified by
   --  Name in the security context Context.
   procedure Add_Context (Context   : in out Security_Context;
                          Name      : in String;
                          Value     : in String);

   --  Get the context information registered under the name Name in the security
   --  context Context.
   --  Raises Invalid_Context if there is no such information.
   function Get_Context (Context  : in Security_Context;
                         Name     : in String) return String;

   --  Returns True if a context information was registered under the name Name.
   function Has_Context (Context : in Security_Context;
                         Name    : in String) return Boolean;

   --  Get the current security context.
   --  Returns null if the current thread is not associated with any security context.
   function Current return Security_Context_Access;
   pragma Inline_Always (Current);

   --  Check if the permission identified by Permission is allowed according to
   --  the current security context.  The result is cached in the security context and
   --  returned in Result.
   function Has_Permission (Permission : in Security.Permissions.Permission_Index) return Boolean;

   --  Check if the permission identified by Permission is allowed according to
   --  the current security context.  The result is cached in the security context and
   --  returned in Result.
   function Has_Permission (Permission : in String) return Boolean;

private

   type Permission_Cache is record
      Perm   : Security.Permissions.Permission_Type;
      Result : Boolean;
   end record;

   type Security_Context is new Ada.Finalization.Limited_Controlled with record
      Previous    : Security_Context_Access := null;
      Manager     : Security.Permissions.Permission_Manager_Access := null;
      Principal   : Security.Principal_Access := null;
      Context     : Util.Strings.Maps.Map;
   end record;

end Security.Contexts;

-----------------------------------------------------------------------
--  security-contexts -- Context to provide security information and verify permissions
--  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.Finalization;

with Util.Strings.Maps;
with Security.Permissions;
with Security.Policies;

--  == Security Context ==
--  The security context provides contextual information for a security controller to
--  verify that a permission is granted.
--  This security context is used as follows:
--
--    * An instance of the security context is declared within a function/procedure as
--      a local variable
--
--    * This instance will be associated with the current thread through a task attribute
--
--    * The security context is populated with information to identify the current user,
--      his roles, permissions and other information that could be used by security controllers
--
--    * To verify a permission, the current security context is retrieved and the
--      Has_Permission operation is called,
--
--    * The Has_Permission will first look in a small cache stored in the security context.
--
--    * When not present in the cache, it will use the security manager to find the
--      security controller associated with the permission to verify
--
--    * The security controller will be called with the security context to check the permission.
--      The whole job of checking the permission is done by the security controller.
--      The security controller retrieves information from the security context to decide
--      whether the permission is granted or not.
--
--    * The result produced by the security controller is then saved in the local cache.
--
package Security.Contexts is

   Invalid_Context : exception;

   type Security_Context is new Ada.Finalization.Limited_Controlled with private;
   type Security_Context_Access is access all Security_Context'Class;

   --  Get the application associated with the current service operation.
   function Get_User_Principal (Context : in Security_Context'Class)
                                return Security.Principal_Access;
   pragma Inline_Always (Get_User_Principal);

   --  Get the permission manager.
   function Get_Permission_Manager (Context : in Security_Context'Class)
                                    return Security.Policies.Policy_Manager_Access;
   pragma Inline_Always (Get_Permission_Manager);

   --  Check if the permission identified by Permission is allowed according to
   --  the current security context.  The result is cached in the security context and
   --  returned in Result.
   procedure Has_Permission (Context    : in out Security_Context;
                             Permission : in Security.Permissions.Permission_Index;
                             Result     : out Boolean);

   --  Check if the permission identified by Permission is allowed according to
   --  the current security context.  The result is cached in the security context and
   --  returned in Result.
   procedure Has_Permission (Context    : in out Security_Context;
                             Permission : in String;
                             Result     : out Boolean);

   --  Initializes the service context.  By creating the Security_Context variable,
   --  the instance will be associated with the current task attribute.  If the current task
   --  already has a security context, the new security context is installed, the old one
   --  being kept.
   overriding
   procedure Initialize (Context : in out Security_Context);

   --  Finalize the security context releases any object.  The previous security context is
   --  restored to the current task attribute.
   overriding
   procedure Finalize (Context : in out Security_Context);

   --  Set the current application and user context.
   procedure Set_Context (Context   : in out Security_Context;
                          Manager   : in Security.Policies.Policy_Manager_Access;
                          Principal : in Security.Principal_Access);

   --  Add a context information represented by Value under the name identified by
   --  Name in the security context Context.
   procedure Add_Context (Context   : in out Security_Context;
                          Name      : in String;
                          Value     : in String);

   --  Get the context information registered under the name Name in the security
   --  context Context.
   --  Raises Invalid_Context if there is no such information.
   function Get_Context (Context  : in Security_Context;
                         Name     : in String) return String;

   --  Returns True if a context information was registered under the name Name.
   function Has_Context (Context : in Security_Context;
                         Name    : in String) return Boolean;

   --  Get the current security context.
   --  Returns null if the current thread is not associated with any security context.
   function Current return Security_Context_Access;
   pragma Inline_Always (Current);

   --  Check if the permission identified by Permission is allowed according to
   --  the current security context.  The result is cached in the security context and
   --  returned in Result.
   function Has_Permission (Permission : in Security.Permissions.Permission_Index) return Boolean;

   --  Check if the permission identified by Permission is allowed according to
   --  the current security context.  The result is cached in the security context and
   --  returned in Result.
   function Has_Permission (Permission : in String) return Boolean;

private

   type Permission_Cache is record
      Perm   : Security.Permissions.Permission_Type;
      Result : Boolean;
   end record;

   type Security_Context is new Ada.Finalization.Limited_Controlled with record
      Previous    : Security_Context_Access := null;
      Manager     : Security.Policies.Policy_Manager_Access := null;
      Principal   : Security.Principal_Access := null;
      Context     : Util.Strings.Maps.Map;
   end record;

end Security.Contexts;

Use the Policy manager

Use the Policy manager