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

with Ada.Unchecked_Deallocation;
with ASF.Applications.Main;
with ASF.Navigations.Render;
package body ASF.Navigations is

   --  ------------------------------
   --  Navigation Case
   --  ------------------------------

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("ASF.Navigations");

   --  ------------------------------
   --  Check if the navigator specific condition matches the current execution context.
   --  ------------------------------
   function Matches (Navigator : in Navigation_Case;
                     Action    : in String;
                     Outcome   : in String;
                     Context   : in ASF.Contexts.Faces.Faces_Context'Class) return Boolean is
   begin
      --  outcome must match
      if Navigator.Outcome /= null and then Navigator.Outcome.all /= Outcome then
         return False;
      end if;

      --  action must match
      if Navigator.Action /= null and then Navigator.Action.all /= Action then
         return False;
      end if;

      --  condition must be true
      if not Navigator.Condition.Is_Constant then
         declare
            Value : constant Util.Beans.Objects.Object
              := Navigator.Condition.Get_Value (Context.Get_ELContext.all);
         begin
            if not Util.Beans.Objects.To_Boolean (Value) then
               return False;
            end if;
         end;
      end if;

      return True;
   end Matches;

   --  ------------------------------
   --  Navigation Rule
   --  ------------------------------

   --  ------------------------------
   --  Search for the navigator that matches the current action, outcome and context.
   --  Returns the navigator or null if there was no match.
   --  ------------------------------
   function Find_Navigation (Controller : in Rule;
                             Action     : in String;
                             Outcome    : in String;
                             Context    : in Contexts.Faces.Faces_Context'Class)
                             return Navigation_Access is
      Iter      : Navigator_Vector.Cursor := Controller.Navigators.First;
      Navigator : Navigation_Access;
   begin
      while Navigator_Vector.Has_Element (Iter) loop
         Navigator := Navigator_Vector.Element (Iter);

         --  Check if this navigator matches the action/outcome.
         if Navigator.Matches (Action, Outcome, Context) then
            return Navigator;
         end if;
         Navigator_Vector.Next (Iter);
      end loop;
      return null;
   end Find_Navigation;

   --  ------------------------------
   --  Clear the navigation rules.
   --  ------------------------------
   procedure Clear (Controller : in out Rule) is
      procedure Free is new Ada.Unchecked_Deallocation (Navigation_Case'Class,
                                                        Navigation_Access);
   begin
      while not Controller.Navigators.Is_Empty loop
         declare
            Iter      : Navigator_Vector.Cursor := Controller.Navigators.Last;
            Navigator : Navigation_Access := Navigator_Vector.Element (Iter);
         begin
            Free (Navigator.Outcome);
            Free (Navigator.Action);
            Free (Navigator);
            Controller.Navigators.Delete (Iter);
         end;
      end loop;
   end Clear;

   --  ------------------------------
   --  Clear the navigation rules.
   --  ------------------------------
   procedure Clear (Controller : in out Navigation_Rules) is
      procedure Free is new Ada.Unchecked_Deallocation (Rule'Class, Rule_Access);
   begin
      while not Controller.Rules.Is_Empty loop
         declare
            Iter : Rule_Map.Cursor := Controller.Rules.First;
            Rule : Rule_Access := Rule_Map.Element (Iter);
         begin
            Rule.Clear;
            Free (Rule);
            Controller.Rules.Delete (Iter);
         end;
      end loop;
   end Clear;

   --  ------------------------------
   --  Navigation Handler
   --  ------------------------------

   --  ------------------------------
   --  Provide a default navigation rules for the view and the outcome when no application
   --  navigation was found.  The default looks for an XHTML file in the same directory as
   --  the view and which has the base name defined by Outcome.
   --  ------------------------------
   procedure Handle_Default_Navigation (Handler : in Navigation_Handler;
                                        View    : in String;
                                        Outcome : in String;
                                        Context : in out ASF.Contexts.Faces.Faces_Context'Class) is
      Pos          : constant Natural := Util.Strings.Rindex (View, '/');
      Root         : Components.Root.UIViewRoot;
      View_Handler : access ASF.Applications.Views.View_Handler'Class := Handler.View_Handler;
   begin
      if View_Handler = null then
         View_Handler := Handler.Application.Get_View_Handler;
      end if;

      if Pos > 0 then
         declare
            Name : constant String := View (View'First .. Pos) & Outcome;
         begin
            Log.Debug ("Using default navigation from view {0} to {1}", View, Name);

            View_Handler.Create_View (Name, Context, Root);
         end;
      else
         Log.Debug ("Using default navigation from view {0} to {1}", View, View);

         View_Handler.Create_View (Outcome, Context, Root);
      end if;

      --  If the 'outcome' refers to a real view, use it.  Otherwise keep the current view.
      if Components.Root.Get_Root (Root) /= null then
         Context.Set_View_Root (Root);
      end if;

      exception
         when others =>
         Log.Debug ("No suitable navigation rule to navigate from view {0}: {1}",
                    View, Outcome);
         raise;

   end Handle_Default_Navigation;

   --  ------------------------------
   --  After executing an action and getting the action outcome, proceed to the navigation
   --  to the next page.
   --  ------------------------------
   procedure Handle_Navigation (Handler : in Navigation_Handler;
                                Action  : in String;
                                Outcome : in String;
                                Context : in out ASF.Contexts.Faces.Faces_Context'Class) is
      Nav_Rules : constant Navigation_Rules_Access := Handler.Rules;
      View      : constant Components.Root.UIViewRoot := Context.Get_View_Root;
      Name      : constant String := Components.Root.Get_View_Id (View);

      function Find_Navigation (View : in String) return Navigation_Access;

      function Find_Navigation (View : in String) return Navigation_Access is
         Pos : constant Rule_Map.Cursor := Nav_Rules.Rules.Find (To_Unbounded_String (View));
      begin
         if not Rule_Map.Has_Element (Pos) then
            return null;
         end if;

         return Rule_Map.Element (Pos).Find_Navigation (Action, Outcome, Context);
      end Find_Navigation;

      Navigator : Navigation_Access;
   begin
      Log.Info ("Navigate from view {0} and action {1} with outcome {2}", Name, Action, Outcome);

      --  Find an exact match
      Navigator := Find_Navigation (Name);

      --  Find a wildcard match
      if Navigator = null then
         declare
            Last : Natural := Name'Last;
            N    : Natural;
         begin
            loop
               N := Util.Strings.Rindex (Name, '/', Last);
               exit when N = 0;

               Navigator := Find_Navigation (Name (Name'First .. N) & "*");
               exit when Navigator /= null or N = Name'First;
               Last := N - 1;
            end loop;
         end;
      end if;

      --  Execute the navigation action.
      if Navigator /= null then
         Navigator.Navigate (Context);
      else
         Log.Debug ("No navigation rule found for view {0}, action {1} and outcome {2}",
                    Name, Action, Outcome);

         Navigation_Handler'Class (Handler).Handle_Default_Navigation (Name, Outcome, Context);
      end if;
   end Handle_Navigation;

   --  ------------------------------
   --  Initialize the the lifecycle handler.
   --  ------------------------------
   procedure Initialize (Handler : in out Navigation_Handler;
                         App     : access ASF.Applications.Main.Application'Class) is
   begin
      Handler.Rules := new Navigation_Rules;
      Handler.Application := App;
   end Initialize;

   --  ------------------------------
   --  Free the storage used by the navigation handler.
   --  ------------------------------
   overriding
   procedure Finalize (Handler : in out Navigation_Handler) is
      procedure Free is new Ada.Unchecked_Deallocation (Navigation_Rules, Navigation_Rules_Access);
   begin
      if Handler.Rules /= null then
         Clear (Handler.Rules.all);
         Free (Handler.Rules);
      end if;
   end Finalize;

   --  ------------------------------
   --  Add a navigation case to navigate from the view identifier by From
   --  to the result view identified by To.  Some optional conditions are evaluated
   --  The Outcome must match unless it is empty.
   --  The Action must match unless it is empty.
   --  The Condition expression must evaluate to True.
   --  ------------------------------
   procedure Add_Navigation_Case (Handler   : in out Navigation_Handler;
                                  From      : in String;
                                  To        : in String;
                                  Outcome   : in String := "";
                                  Action    : in String := "";
                                  Condition : in String := "";
                                  Context   : in EL.Contexts.ELContext'Class) is
      C : constant Navigation_Access := Render.Create_Render_Navigator (To);
   begin
      Handler.Add_Navigation_Case (C, From, Outcome, Action, Condition, Context);
   end Add_Navigation_Case;

   --  ------------------------------
   --  Add a navigation case to navigate from the view identifier by From
   --  by using the navigation rule defined by Navigator.
   --  Some optional conditions are evaluated:
   --  The Outcome must match unless it is empty.
   --  The Action must match unless it is empty.
   --  The Condition expression must evaluate to True.
   --  ------------------------------
   procedure Add_Navigation_Case (Handler   : in out Navigation_Handler'Class;
                                  Navigator : in Navigation_Access;
                                  From      : in String;
                                  Outcome   : in String := "";
                                  Action    : in String := "";
                                  Condition : in String := "";
                                  Context   : in EL.Contexts.ELContext'Class) is
   begin
      Log.Info ("Add navigation from {0} with outcome {1}", From, Outcome);

      if Outcome'Length > 0 then
         Navigator.Outcome := new String '(Outcome);
      end if;
      if Action'Length > 0 then
         Navigator.Action := new String '(Action);
      end if;

      if Handler.View_Handler = null then
         Handler.View_Handler := Handler.Application.Get_View_Handler;
      end if;

      if Condition'Length > 0 then
         Navigator.Condition := EL.Expressions.Create_Expression (Condition, Context);
      end if;

      Navigator.View_Handler := Handler.View_Handler;
      declare
         View : constant Unbounded_String := To_Unbounded_String (From);
         Pos  : constant Rule_Map.Cursor := Handler.Rules.Rules.Find (View);
         R    : Rule_Access;
      begin
         if not Rule_Map.Has_Element (Pos) then
            R := new Rule;
            Handler.Rules.Rules.Include (Key      => View,
                                         New_Item => R);
         else
            R := Rule_Map.Element (Pos);
         end if;

         R.Navigators.Append (Navigator);
      end;
   end Add_Navigation_Case;

end ASF.Navigations;

-----------------------------------------------------------------------
--  asf-navigations -- Navigations
--  Copyright (C) 2010, 2011, 2012, 2013, 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 ASF.Components.Root;
with Util.Strings;
with Util.Beans.Objects;
with Util.Log.Loggers;

with Ada.Unchecked_Deallocation;
with ASF.Applications.Main;
with ASF.Navigations.Render;
package body ASF.Navigations is

   --  ------------------------------
   --  Navigation Case
   --  ------------------------------

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("ASF.Navigations");

   --  ------------------------------
   --  Check if the navigator specific condition matches the current execution context.
   --  ------------------------------
   function Matches (Navigator : in Navigation_Case;
                     Action    : in String;
                     Outcome   : in String;
                     Context   : in ASF.Contexts.Faces.Faces_Context'Class) return Boolean is
   begin
      --  outcome must match
      if Navigator.Outcome /= null and then Navigator.Outcome.all /= Outcome then
         return False;
      end if;

      --  action must match
      if Navigator.Action /= null and then Navigator.Action.all /= Action then
         return False;
      end if;

      --  condition must be true
      if not Navigator.Condition.Is_Constant then
         declare
            Value : constant Util.Beans.Objects.Object
              := Navigator.Condition.Get_Value (Context.Get_ELContext.all);
         begin
            if not Util.Beans.Objects.To_Boolean (Value) then
               return False;
            end if;
         end;
      end if;

      return True;
   end Matches;

   --  ------------------------------
   --  Navigation Rule
   --  ------------------------------

   --  ------------------------------
   --  Search for the navigator that matches the current action, outcome and context.
   --  Returns the navigator or null if there was no match.
   --  ------------------------------
   function Find_Navigation (Controller : in Rule;
                             Action     : in String;
                             Outcome    : in String;
                             Context    : in Contexts.Faces.Faces_Context'Class)
                             return Navigation_Access is
      Iter      : Navigator_Vector.Cursor := Controller.Navigators.First;
      Navigator : Navigation_Access;
   begin
      while Navigator_Vector.Has_Element (Iter) loop
         Navigator := Navigator_Vector.Element (Iter);

         --  Check if this navigator matches the action/outcome.
         if Navigator.Matches (Action, Outcome, Context) then
            return Navigator;
         end if;
         Navigator_Vector.Next (Iter);
      end loop;
      return null;
   end Find_Navigation;

   --  ------------------------------
   --  Clear the navigation rules.
   --  ------------------------------
   procedure Clear (Controller : in out Rule) is
      procedure Free is new Ada.Unchecked_Deallocation (Navigation_Case'Class,
                                                        Navigation_Access);
   begin
      while not Controller.Navigators.Is_Empty loop
         declare
            Iter      : Navigator_Vector.Cursor := Controller.Navigators.Last;
            Navigator : Navigation_Access := Navigator_Vector.Element (Iter);
         begin
            Free (Navigator.Outcome);
            Free (Navigator.Action);
            Free (Navigator);
            Controller.Navigators.Delete (Iter);
         end;
      end loop;
   end Clear;

   --  ------------------------------
   --  Clear the navigation rules.
   --  ------------------------------
   procedure Clear (Controller : in out Navigation_Rules) is
      procedure Free is new Ada.Unchecked_Deallocation (Rule'Class, Rule_Access);
   begin
      while not Controller.Rules.Is_Empty loop
         declare
            Iter : Rule_Map.Cursor := Controller.Rules.First;
            Rule : Rule_Access := Rule_Map.Element (Iter);
         begin
            Rule.Clear;
            Free (Rule);
            Controller.Rules.Delete (Iter);
         end;
      end loop;
   end Clear;

   --  ------------------------------
   --  Navigation Handler
   --  ------------------------------

   --  ------------------------------
   --  Provide a default navigation rules for the view and the outcome when no application
   --  navigation was found.  The default looks for an XHTML file in the same directory as
   --  the view and which has the base name defined by Outcome.
   --  ------------------------------
   procedure Handle_Default_Navigation (Handler : in Navigation_Handler;
                                        View    : in String;
                                        Outcome : in String;
                                        Context : in out ASF.Contexts.Faces.Faces_Context'Class) is
      Pos          : constant Natural := Util.Strings.Rindex (View, '/');
      Root         : Components.Root.UIViewRoot;
      View_Handler : access ASF.Applications.Views.View_Handler'Class := Handler.View_Handler;
   begin
      if View_Handler = null then
         View_Handler := Handler.Application.Get_View_Handler;
      end if;

      if Pos > 0 then
         declare
            Name : constant String := View (View'First .. Pos) & Outcome;
         begin
            Log.Debug ("Using default navigation from view {0} to {1}", View, Name);

            View_Handler.Create_View (Name, Context, Root);
         end;
      else
         Log.Debug ("Using default navigation from view {0} to {1}", View, View);

         View_Handler.Create_View (Outcome, Context, Root);
      end if;

      --  If the 'outcome' refers to a real view, use it.  Otherwise keep the current view.
      if Components.Root.Get_Root (Root) /= null then
         Context.Set_View_Root (Root);
      end if;

      exception
         when others =>
         Log.Debug ("No suitable navigation rule to navigate from view {0}: {1}",
                    View, Outcome);
         raise;

   end Handle_Default_Navigation;

   --  ------------------------------
   --  After executing an action and getting the action outcome, proceed to the navigation
   --  to the next page.
   --  ------------------------------
   procedure Handle_Navigation (Handler : in Navigation_Handler;
                                Action  : in String;
                                Outcome : in String;
                                Context : in out ASF.Contexts.Faces.Faces_Context'Class) is
      Nav_Rules : constant Navigation_Rules_Access := Handler.Rules;
      View      : constant Components.Root.UIViewRoot := Context.Get_View_Root;
      Name      : constant String := Components.Root.Get_View_Id (View);

      function Find_Navigation (View : in String) return Navigation_Access;

      function Find_Navigation (View : in String) return Navigation_Access is
         Pos : constant Rule_Map.Cursor := Nav_Rules.Rules.Find (To_Unbounded_String (View));
      begin
         if not Rule_Map.Has_Element (Pos) then
            return null;
         end if;

         return Rule_Map.Element (Pos).Find_Navigation (Action, Outcome, Context);
      end Find_Navigation;

      Navigator : Navigation_Access;
   begin
      Log.Info ("Navigate from view {0} and action {1} with outcome {2}", Name, Action, Outcome);

      --  Find an exact match
      Navigator := Find_Navigation (Name);

      --  Find a wildcard match
      if Navigator = null then
         declare
            Last : Natural := Name'Last;
            N    : Natural;
         begin
            loop
               N := Util.Strings.Rindex (Name, '/', Last);
               exit when N = 0;

               Navigator := Find_Navigation (Name (Name'First .. N) & "*");
               exit when Navigator /= null or N = Name'First;
               Last := N - 1;
            end loop;
         end;
      end if;

      --  Execute the navigation action.
      if Navigator /= null then
         Navigator.Navigate (Context);
      else
         Log.Debug ("No navigation rule found for view {0}, action {1} and outcome {2}",
                    Name, Action, Outcome);

         Navigation_Handler'Class (Handler).Handle_Default_Navigation (Name, Outcome, Context);
      end if;
   end Handle_Navigation;

   --  ------------------------------
   --  Initialize the the lifecycle handler.
   --  ------------------------------
   procedure Initialize (Handler : in out Navigation_Handler;
                         App     : access ASF.Applications.Main.Application'Class) is
   begin
      Handler.Rules := new Navigation_Rules;
      Handler.Application := App;
   end Initialize;

   --  ------------------------------
   --  Free the storage used by the navigation handler.
   --  ------------------------------
   overriding
   procedure Finalize (Handler : in out Navigation_Handler) is
      procedure Free is new Ada.Unchecked_Deallocation (Navigation_Rules, Navigation_Rules_Access);
   begin
      if Handler.Rules /= null then
         Clear (Handler.Rules.all);
         Free (Handler.Rules);
      end if;
   end Finalize;

   --  ------------------------------
   --  Add a navigation case to navigate from the view identifier by From
   --  to the result view identified by To.  Some optional conditions are evaluated
   --  The Outcome must match unless it is empty.
   --  The Action must match unless it is empty.
   --  The Condition expression must evaluate to True.
   --  ------------------------------
   procedure Add_Navigation_Case (Handler   : in out Navigation_Handler;
                                  From      : in String;
                                  To        : in String;
                                  Outcome   : in String := "";
                                  Action    : in String := "";
                                  Condition : in String := "";
                                  Context   : in EL.Contexts.ELContext'Class) is
      C : constant Navigation_Access := Render.Create_Render_Navigator (To, 0);
   begin
      Handler.Add_Navigation_Case (C, From, Outcome, Action, Condition, Context);
   end Add_Navigation_Case;

   --  ------------------------------
   --  Add a navigation case to navigate from the view identifier by From
   --  by using the navigation rule defined by Navigator.
   --  Some optional conditions are evaluated:
   --  The Outcome must match unless it is empty.
   --  The Action must match unless it is empty.
   --  The Condition expression must evaluate to True.
   --  ------------------------------
   procedure Add_Navigation_Case (Handler   : in out Navigation_Handler'Class;
                                  Navigator : in Navigation_Access;
                                  From      : in String;
                                  Outcome   : in String := "";
                                  Action    : in String := "";
                                  Condition : in String := "";
                                  Context   : in EL.Contexts.ELContext'Class) is
   begin
      Log.Info ("Add navigation from {0} with outcome {1}", From, Outcome);

      if Outcome'Length > 0 then
         Navigator.Outcome := new String '(Outcome);
      end if;
      if Action'Length > 0 then
         Navigator.Action := new String '(Action);
      end if;

      if Handler.View_Handler = null then
         Handler.View_Handler := Handler.Application.Get_View_Handler;
      end if;

      if Condition'Length > 0 then
         Navigator.Condition := EL.Expressions.Create_Expression (Condition, Context);
      end if;

      Navigator.View_Handler := Handler.View_Handler;
      declare
         View : constant Unbounded_String := To_Unbounded_String (From);
         Pos  : constant Rule_Map.Cursor := Handler.Rules.Rules.Find (View);
         R    : Rule_Access;
      begin
         if not Rule_Map.Has_Element (Pos) then
            R := new Rule;
            Handler.Rules.Rules.Include (Key      => View,
                                         New_Item => R);
         else
            R := Rule_Map.Element (Pos);
         end if;

         R.Navigators.Append (Navigator);
      end;
   end Add_Navigation_Case;

end ASF.Navigations;

Update call to Create_Render_Navigator

Update call to Create_Render_Navigator


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

with Ada.Real_Time;
with Ada.Tags;
with Ada.Text_IO;

with Orka.Containers.Bounded_Vectors;
with Orka.Futures;

package body Orka.Jobs.Executors is

   function Get_Root_Dependent (Element : Job_Ptr) return Job_Ptr is
      Result : Job_Ptr := Element;
   begin
      while Result.Dependent /= Null_Job loop
         Result := Result.Dependent;
      end loop;
      return Result;
   end Get_Root_Dependent;

   procedure Execute_Jobs
     (Name  : String;
      Kind  : Queues.Executor_Kind;
      Queue : Queues.Queue_Ptr)
   is
      use type Ada.Real_Time.Time;
      use type Futures.Status;

      Pair : Queues.Pair;
      Stop : Boolean := False;

      Null_Pair : constant Queues.Pair := Queues.Get_Null_Pair;

      package Vectors is new Orka.Containers.Bounded_Vectors (Job_Ptr, Get_Null_Job);

      T0, T1, T2 : Ada.Real_Time.Time;
   begin
      loop
         T0 := Ada.Real_Time.Clock;
         Queue.Dequeue (Kind) (Pair, Stop);
         exit when Stop;

         declare
            Job     : Job_Ptr renames Pair.Job;

            Future  : Futures.Pointers.Reference renames Pair.Future.Get;
            Promise : Futures.Promise'Class renames Futures.Promise'Class (Future.Value.all);

            Jobs : Vectors.Vector (Capacity => Maximum_Enqueued_By_Job);

            procedure Enqueue (Element : Job_Ptr) is
            begin
               Jobs.Append (Element);
            end Enqueue;

            procedure Set_Root_Dependent (Last_Job : Job_Ptr) is
               Root_Dependents : Vectors.Vector (Capacity => Jobs.Length);

               procedure Set_Dependencies (Elements : Vectors.Element_Array) is
               begin
                  Last_Job.Set_Dependencies (Dependency_Array (Elements));
               end Set_Dependencies;
            begin
               for Job of Jobs loop
                  declare
                     Root : constant Job_Ptr := Get_Root_Dependent (Job);
                  begin
                     if not (for some Dependent of Root_Dependents => Root = Dependent) then
                        Root_Dependents.Append (Root);
                     end if;
                  end;
               end loop;

               Root_Dependents.Query (Set_Dependencies'Access);
            end Set_Root_Dependent;
         begin
            T1 := Ada.Real_Time.Clock;

            if Future.Current_Status = Futures.Waiting then
               Promise.Set_Status (Futures.Running);
            end if;

            begin
               Job.Execute (Enqueue'Access);
            exception
               when Error : others =>
                  Promise.Set_Failed (Error);
                  raise;
            end;

            T2 := Ada.Real_Time.Clock;

            declare
               Waiting_Time : constant Duration := 1e3 * Ada.Real_Time.To_Duration (T1 - T0);
               Running_Time : constant Duration := 1e3 * Ada.Real_Time.To_Duration (T2 - T1);
               Tag : String renames Ada.Tags.Expanded_Name (Job'Tag);
            begin
               Ada.Text_IO.Put_Line (Name & " (blocked" & Waiting_Time'Image & " ms) executed job " & Tag & " in" & Running_Time'Image & " ms");
            end;

            if Job.Dependent /= Null_Job then
               --  Make the root dependents of the jobs in Jobs
               --  dependencies of Job.Dependent
               if not Jobs.Empty then
                  Set_Root_Dependent (Job.Dependent);
               end if;

               --  If another job depends on this job, decrement its dependencies counter
               --  and if it has reached zero then it can be scheduled
               if Job.Dependent.Decrement_Dependencies then
                  Queue.Enqueue (Job.Dependent, Pair.Future);
               end if;
            elsif Jobs.Empty then
               Promise.Set_Status (Futures.Done);
            else
               --  If the job has enqueued new jobs, we need to create an
               --  empty job which has the root dependents of these new jobs
               --  as dependencies. This is so that the empty job will be the
               --  last job that is given Pair.Future
               Set_Root_Dependent (Create_Empty_Job);
            end if;

            if not Jobs.Empty then
               for Job of Jobs loop
                  Queue.Enqueue (Job, Pair.Future);
               end loop;
            end if;

            Free (Job);
         end;

         --  Finalize the smart pointer (Pair.Future) to reduce the number
         --  of references to the Future object
         Pair := Null_Pair;
      end loop;
   end Execute_Jobs;

end Orka.Jobs.Executors;

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

with Ada.Real_Time;
--  with Ada.Tags;
--  with Ada.Text_IO;

with Orka.Containers.Bounded_Vectors;
with Orka.Futures;

package body Orka.Jobs.Executors is

   function Get_Root_Dependent (Element : Job_Ptr) return Job_Ptr is
      Result : Job_Ptr := Element;
   begin
      while Result.Dependent /= Null_Job loop
         Result := Result.Dependent;
      end loop;
      return Result;
   end Get_Root_Dependent;

   procedure Execute_Jobs
     (Name  : String;
      Kind  : Queues.Executor_Kind;
      Queue : Queues.Queue_Ptr)
   is
      use type Ada.Real_Time.Time;
      use type Futures.Status;

      Pair : Queues.Pair;
      Stop : Boolean := False;

      Null_Pair : constant Queues.Pair := Queues.Get_Null_Pair;

      package Vectors is new Orka.Containers.Bounded_Vectors (Job_Ptr, Get_Null_Job);

--      T0, T1, T2 : Ada.Real_Time.Time;
   begin
      loop
--         T0 := Ada.Real_Time.Clock;
         Queue.Dequeue (Kind) (Pair, Stop);
         exit when Stop;

         declare
            Job     : Job_Ptr renames Pair.Job;

            Future  : Futures.Pointers.Reference renames Pair.Future.Get;
            Promise : Futures.Promise'Class renames Futures.Promise'Class (Future.Value.all);

            Jobs : Vectors.Vector (Capacity => Maximum_Enqueued_By_Job);

            procedure Enqueue (Element : Job_Ptr) is
            begin
               Jobs.Append (Element);
            end Enqueue;

            procedure Set_Root_Dependent (Last_Job : Job_Ptr) is
               Root_Dependents : Vectors.Vector (Capacity => Jobs.Length);

               procedure Set_Dependencies (Elements : Vectors.Element_Array) is
               begin
                  Last_Job.Set_Dependencies (Dependency_Array (Elements));
               end Set_Dependencies;
            begin
               for Job of Jobs loop
                  declare
                     Root : constant Job_Ptr := Get_Root_Dependent (Job);
                  begin
                     if not (for some Dependent of Root_Dependents => Root = Dependent) then
                        Root_Dependents.Append (Root);
                     end if;
                  end;
               end loop;

               Root_Dependents.Query (Set_Dependencies'Access);
            end Set_Root_Dependent;

--            Tag : String renames Ada.Tags.Expanded_Name (Job'Tag);
         begin
--            T1 := Ada.Real_Time.Clock;

--            Ada.Text_IO.Put_Line (Name & " executing job " & Tag);
            if Future.Current_Status = Futures.Waiting then
               Promise.Set_Status (Futures.Running);
            end if;

            begin
               Job.Execute (Enqueue'Access);
            exception
               when Error : others =>
                  Promise.Set_Failed (Error);
                  raise;
            end;

--            T2 := Ada.Real_Time.Clock;
--            declare
--               Waiting_Time : constant Duration := 1e3 * Ada.Real_Time.To_Duration (T1 - T0);
--               Running_Time : constant Duration := 1e3 * Ada.Real_Time.To_Duration (T2 - T1);
--            begin
--               Ada.Text_IO.Put_Line (Name & " (blocked" & Waiting_Time'Image & " ms) executed job " & Tag & " in" & Running_Time'Image & " ms");
--            end;

            if Job.Dependent /= Null_Job then
               --  Make the root dependents of the jobs in Jobs
               --  dependencies of Job.Dependent
               if not Jobs.Empty then
                  Set_Root_Dependent (Job.Dependent);
               end if;

               --  If another job depends on this job, decrement its dependencies counter
               --  and if it has reached zero then it can be scheduled
               if Job.Dependent.Decrement_Dependencies then
                  Queue.Enqueue (Job.Dependent, Pair.Future);
               end if;
            elsif Jobs.Empty then
               Promise.Set_Status (Futures.Done);
--               Ada.Text_IO.Put_Line (Name & " completed graph with job " & Tag);
            else
               --  If the job has enqueued new jobs, we need to create an
               --  empty job which has the root dependents of these new jobs
               --  as dependencies. This is so that the empty job will be the
               --  last job that is given Pair.Future
               Set_Root_Dependent (Create_Empty_Job);
            end if;

            if not Jobs.Empty then
               for Job of Jobs loop
                  Queue.Enqueue (Job, Pair.Future);
               end loop;
            end if;

            Free (Job);
         end;

         --  Finalize the smart pointer (Pair.Future) to reduce the number
         --  of references to the Future object
         Pair := Null_Pair;
      end loop;
   end Execute_Jobs;

end Orka.Jobs.Executors;

orka: Comment debugging prints in package Orka.Jobs.Executors

These prints are generated each frame for every job, so they generate a
lot of text. Keep it commented in the code though because it's still
useful for debugging.

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


-----------------------------------------------------------------------
--  EL.Objects.Hash -- Hash on an object
--  Copyright (C) 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.
-----------------------------------------------------------------------

with Ada.Strings.Hash;
with Ada.Characters.Conversions;
with Ada.Unchecked_Conversion;
with Interfaces;
with EL.Beans;
function EL.Objects.Hash (Key : in Object) return Ada.Containers.Hash_Type is
   use Ada.Containers;
   use Ada.Strings;
   use Ada.Characters.Conversions;
   use Interfaces;
   use EL.Beans;

   type Unsigned_32_Array is array (Natural range <>) of Unsigned_32;

   subtype U32_For_Float is Unsigned_32_Array (1 .. Long_Long_Float'Size / 32);

   subtype U32_For_Long is Unsigned_32_Array (1 .. Long_Long_Integer'Size / 32);

   subtype U32_For_Access is Unsigned_32_Array (1 .. Readonly_Bean_Access'Size / 32);

   --  Hash the integer and floats using 32-bit values.
   function To_U32_For_Long is new Ada.Unchecked_Conversion (Source => Long_Long_Integer,
                                                             Target => U32_For_Long);

   --  Likewise for floats.
   function To_U32_For_Float is new Ada.Unchecked_Conversion (Source => Long_Long_Float,
                                                              Target => U32_For_Float);

   --  Likewise for the bean pointer
   function To_U32_For_Access is new Ada.Unchecked_Conversion (Source => Readonly_Bean_Access,
                                                               Target => U32_For_Access);

   Value : Unsigned_64 := 0;
begin
   case key.V.Of_Type is
      when TYPE_NULL =>
         return 0;

      when TYPE_BOOLEAN =>
         if Key.V.Bool_Value then
            return 1;
         else
            return 2;
         end if;

      when TYPE_INTEGER =>
         declare
            U32 : constant U32_For_Long :=  To_U32_For_Long (Key.V.Int_Value);
            Val : Unsigned_32 := U32 (U32'First);
         begin
            for I in U32'First + 1 .. U32'Last loop
               Val := Val xor U32 (I);
            end loop;
            return Hash_Type (Val);
         end;

      when TYPE_FLOAT =>
         declare
            U32 : constant U32_For_Float :=  To_U32_For_Float (Key.V.Float_Value);
            Val : Unsigned_32 := U32 (U32'First);
         begin
            for I in U32'First + 1 .. U32'Last loop
               Val := Val xor U32 (I);
            end loop;
            return Hash_Type (Val);
         end;

      when TYPE_STRING =>
         if Key.V.Proxy = null then
            return 0;
         else
            return Hash (Key.V.Proxy.String_Value.all);
         end if;

      when TYPE_TIME =>
         declare
            U32 : constant U32_For_Long :=  To_U32_For_Long (Key.V.Time_Value);
            Val : Unsigned_32 := U32 (U32'First);
         begin
            for I in U32'First + 1 .. U32'Last loop
               Val := Val xor U32 (I);
            end loop;
            return Hash_Type (Val);
         end;

      when TYPE_WIDE_STRING =>
         if Key.V.Proxy = null then
            return 0;
         else
            return Hash (To_String (Key.V.Proxy.Wide_String_Value.all));
         end if;

      when TYPE_BEAN =>
         if Key.V.Proxy.Bean = null then
            return 0;
         end if;
         declare
            U32 : constant U32_For_Access :=  To_U32_For_Access (Key.V.Proxy.Bean.all'Access);
            Val : Unsigned_32 := U32 (U32'First);

            --  The loop is not executed if pointers are 32-bit wide.
            pragma Warnings (Off);
         begin
            for I in U32'First + 1 .. U32'Last loop
               Val := Val xor U32 (I);
            end loop;
            return Hash_Type (Val);
         end;

   end case;

   --  Hash the 64-bit value into a 32-bit result that fits in Hash_Type.
   Value := (Value and 16#0ffffffff#) xor (Shift_Right (Value, 32));
   return Hash_Type (Value);
end EL.Objects.Hash;

-----------------------------------------------------------------------
--  EL.Objects.Hash -- Hash on an object
--  Copyright (C) 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.
-----------------------------------------------------------------------

with Ada.Strings.Hash;
with Ada.Characters.Conversions;
with Ada.Unchecked_Conversion;
with Interfaces;
with EL.Beans;
function EL.Objects.Hash (Key : in Object) return Ada.Containers.Hash_Type is
   use Ada.Containers;
   use Ada.Strings;
   use Ada.Characters.Conversions;
   use Interfaces;
   use EL.Beans;

   type Unsigned_32_Array is array (Natural range <>) of Unsigned_32;

   subtype U32_For_Float is Unsigned_32_Array (1 .. Long_Long_Float'Size / 32);

   subtype U32_For_Long is Unsigned_32_Array (1 .. Long_Long_Integer'Size / 32);

   subtype U32_For_Access is Unsigned_32_Array (1 .. Readonly_Bean_Access'Size / 32);

   --  Hash the integer and floats using 32-bit values.
   function To_U32_For_Long is new Ada.Unchecked_Conversion (Source => Long_Long_Integer,
                                                             Target => U32_For_Long);

   --  Likewise for floats.
   function To_U32_For_Float is new Ada.Unchecked_Conversion (Source => Long_Long_Float,
                                                              Target => U32_For_Float);

   --  Likewise for the bean pointer
   function To_U32_For_Access is new Ada.Unchecked_Conversion (Source => Readonly_Bean_Access,
                                                               Target => U32_For_Access);

begin
   case key.V.Of_Type is
      when TYPE_NULL =>
         return 0;

      when TYPE_BOOLEAN =>
         if Key.V.Bool_Value then
            return 1;
         else
            return 2;
         end if;

      when TYPE_INTEGER =>
         declare
            U32 : constant U32_For_Long :=  To_U32_For_Long (Key.V.Int_Value);
            Val : Unsigned_32 := U32 (U32'First);
         begin
            for I in U32'First + 1 .. U32'Last loop
               Val := Val xor U32 (I);
            end loop;
            return Hash_Type (Val);
         end;

      when TYPE_FLOAT =>
         declare
            U32 : constant U32_For_Float :=  To_U32_For_Float (Key.V.Float_Value);
            Val : Unsigned_32 := U32 (U32'First);
         begin
            for I in U32'First + 1 .. U32'Last loop
               Val := Val xor U32 (I);
            end loop;
            return Hash_Type (Val);
         end;

      when TYPE_STRING =>
         if Key.V.Proxy = null then
            return 0;
         else
            return Hash (Key.V.Proxy.String_Value.all);
         end if;

      when TYPE_TIME =>
         declare
            U32 : constant U32_For_Long :=  To_U32_For_Long (Key.V.Time_Value);
            Val : Unsigned_32 := U32 (U32'First);
         begin
            for I in U32'First + 1 .. U32'Last loop
               Val := Val xor U32 (I);
            end loop;
            return Hash_Type (Val);
         end;

      when TYPE_WIDE_STRING =>
         if Key.V.Proxy = null then
            return 0;
         else
            return Hash (To_String (Key.V.Proxy.Wide_String_Value.all));
         end if;

      when TYPE_BEAN =>
         if Key.V.Proxy.Bean = null then
            return 0;
         end if;
         declare
            U32 : constant U32_For_Access :=  To_U32_For_Access (Key.V.Proxy.Bean.all'Access);
            Val : Unsigned_32 := U32 (U32'First);

            --  The loop is not executed if pointers are 32-bit wide.
            pragma Warnings (Off);
         begin
            for I in U32'First + 1 .. U32'Last loop
               Val := Val xor U32 (I);
            end loop;
            return Hash_Type (Val);
         end;

   end case;
end EL.Objects.Hash;

Remove unreachable code

Remove unreachable code


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

with AWA.Applications;

with Util.Beans.Objects;

with EL.Functions;

with ADO;
with ADO.Sessions;
with ADO.Objects;

with Security.Policies;
with Security.Contexts;
package AWA.Permissions.Services is

   --  Register the security EL functions in the EL mapper.
   procedure Set_Functions (Mapper : in out EL.Functions.Function_Mapper'Class);

   type Permission_Manager is new Security.Policies.Policy_Manager with private;
   type Permission_Manager_Access is access all Permission_Manager'Class;

   --  Get the permission manager associated with the security context.
   --  Returns null if there is none.
   function Get_Permission_Manager (Context : in Security.Contexts.Security_Context'Class)
                                    return Permission_Manager_Access;

   --  Get the application instance.
   function Get_Application (Manager : in Permission_Manager)
                             return AWA.Applications.Application_Access;

   --  Set the application instance.
   procedure Set_Application (Manager : in out Permission_Manager;
                              App : in AWA.Applications.Application_Access);

   --  Add a permission for the current user to access the entity identified by
   --  Entity and Kind in the Workspace.
   procedure Add_Permission (Manager    : in Permission_Manager;
                             Entity     : in ADO.Identifier;
                             Kind       : in ADO.Entity_Type;
                             Workspace  : in ADO.Identifier;
                             Permission : in Permission_Type);

   --  Check that the current user has the specified permission.
   --  Raise NO_PERMISSION exception if the user does not have the permission.
   procedure Check_Permission (Manager    : in Permission_Manager;
                               Entity     : in ADO.Identifier;
                               Kind       : in ADO.Entity_Type;
                               Permission : in Permission_Type);

   --  Add a permission for the user User to access the entity identified by
   --  Entity which is of type Kind.
   procedure Add_Permission (Session    : in out ADO.Sessions.Master_Session;
                             User       : in ADO.Identifier;
                             Entity     : in ADO.Identifier;
                             Kind       : in ADO.Entity_Type;
                             Workspace  : in ADO.Identifier;
                             Permission : in Permission_Type := READ);

   --  Add a permission for the user User to access the entity identified by
   --  Entity.
   procedure Add_Permission (Session    : in out ADO.Sessions.Master_Session;
                             User       : in ADO.Identifier;
                             Entity     : in ADO.Objects.Object_Ref'Class;
                             Workspace  : in ADO.Identifier;
                             Permission : in Permission_Type := READ);

   --  Create a permission manager for the given application.
   function Create_Permission_Manager (App : in AWA.Applications.Application_Access)
                                       return Security.Policies.Policy_Manager_Access;

   --  Check if the permission with the name <tt>Name</tt> is granted for the current user.
   --  If the <tt>Entity</tt> is defined, an <tt>Entity_Permission</tt> is created and verified.
   --  Returns True if the user is granted the given permission.
   function Has_Permission (Name   : in Util.Beans.Objects.Object;
                            Entity : in Util.Beans.Objects.Object)
                            return Util.Beans.Objects.Object;

private

   type Permission_Manager is new Security.Policies.Policy_Manager with record
      App : AWA.Applications.Application_Access := null;
   end record;

end AWA.Permissions.Services;

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

with AWA.Applications;

with Util.Beans.Objects;

with EL.Functions;

with ADO;
with ADO.Sessions;
with ADO.Objects;

with Security.Policies;
with Security.Contexts;
package AWA.Permissions.Services is

   --  Register the security EL functions in the EL mapper.
   procedure Set_Functions (Mapper : in out EL.Functions.Function_Mapper'Class);

   type Permission_Manager is new Security.Policies.Policy_Manager with private;
   type Permission_Manager_Access is access all Permission_Manager'Class;

   --  Get the permission manager associated with the security context.
   --  Returns null if there is none.
   function Get_Permission_Manager (Context : in Security.Contexts.Security_Context'Class)
                                    return Permission_Manager_Access;

   --  Get the application instance.
   function Get_Application (Manager : in Permission_Manager)
                             return AWA.Applications.Application_Access;

   --  Set the application instance.
   procedure Set_Application (Manager : in out Permission_Manager;
                              App : in AWA.Applications.Application_Access);

   --  Add a permission for the current user to access the entity identified by
   --  Entity and Kind in the Workspace.
   procedure Add_Permission (Manager    : in Permission_Manager;
                             Entity     : in ADO.Identifier;
                             Kind       : in ADO.Entity_Type;
                             Workspace  : in ADO.Identifier;
                             Permission : in Permission_Type);

   --  Check that the current user has the specified permission.
   --  Raise NO_PERMISSION exception if the user does not have the permission.
   procedure Check_Permission (Manager    : in Permission_Manager;
                               Entity     : in ADO.Identifier;
                               Kind       : in ADO.Entity_Type;
                               Permission : in Permission_Type);

   --  Add a permission for the user User to access the entity identified by
   --  Entity which is of type Kind.
   procedure Add_Permission (Session    : in out ADO.Sessions.Master_Session;
                             User       : in ADO.Identifier;
                             Entity     : in ADO.Identifier;
                             Kind       : in ADO.Entity_Type;
                             Workspace  : in ADO.Identifier;
                             Permission : in Permission_Type := READ);

   --  Add a permission for the user User to access the entity identified by
   --  Entity.
   procedure Add_Permission (Session    : in out ADO.Sessions.Master_Session;
                             User       : in ADO.Identifier;
                             Entity     : in ADO.Objects.Object_Ref'Class;
                             Workspace  : in ADO.Identifier;
                             Permission : in Permission_Type := READ);

   --  Create a permission manager for the given application.
   function Create_Permission_Manager (App : in AWA.Applications.Application_Access)
                                       return Security.Policies.Policy_Manager_Access;

   --  Check if the permission with the name <tt>Name</tt> is granted for the current user.
   --  If the <tt>Entity</tt> is defined, an <tt>Entity_Permission</tt> is created and verified.
   --  Returns True if the user is granted the given permission.
   function Has_Permission (Name   : in Util.Beans.Objects.Object;
                            Entity : in Util.Beans.Objects.Object)
                            return Util.Beans.Objects.Object;

   --  Delete all the permissions for a user and on the given workspace.
   procedure Delete_Permissions (Session   : in out ADO.Sessions.Master_Session;
                                 User      : in ADO.Identifier;
                                 Workspace : in ADO.Identifier);

private

   type Permission_Manager is new Security.Policies.Policy_Manager with record
      App : AWA.Applications.Application_Access := null;
   end record;

end AWA.Permissions.Services;

Declare the Delete_Permissions procedure


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

with Util.Tests;

package Util.Systems.Dlls.Tests is

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

   type Test is new Util.Tests.Test with null record;

   --  Test the loading a shared library.
   procedure Test_Load (T : in out Test);

   --  Test getting a shared library symbol.
   procedure Test_Get_Symbol (T : in out Test);

end Util.Systems.Dlls.Tests;

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

with Util.Tests;

package Util.Systems.DLLs.Tests is

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

   type Test is new Util.Tests.Test with null record;

   --  Test the loading a shared library.
   procedure Test_Load (T : in out Test);

   --  Test getting a shared library symbol.
   procedure Test_Get_Symbol (T : in out Test);

end Util.Systems.DLLs.Tests;

Fix compilation warning

Fix compilation warning


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

with Util.Log.Loggers;
with Util.Systems.DLLs;

with System;
with Ada.Strings.Fixed;
with Ada.Containers.Doubly_Linked_Lists;
with Ada.Exceptions;

package body ADO.Drivers.Connections is

   use Ada.Strings.Fixed;

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("ADO.Drivers.Connections");

   --  Load the database driver.
   procedure Load_Driver (Name : in String);

   --  ------------------------------
   --  Set the connection URL to connect to the database.
   --  The driver connection is a string of the form:
   --
   --   driver://[host][:port]/[database][?property1][=value1]...
   --
   --  If the string is invalid or if the driver cannot be found,
   --  the Connection_Error exception is raised.
   --  ------------------------------
   procedure Set_Connection (Controller : in out Configuration;
                             URI        : in String) is

      Pos, Pos2, Slash_Pos, Next : Natural;
   begin
      Log.Info ("Set connection URI: {0}", URI);

      Controller.URI := To_Unbounded_String (URI);
      Pos := Index (URI, "://");
      if Pos <= 1 then
         Log.Error ("Invalid connection URI: {0}", URI);
         raise Connection_Error
           with "Invalid URI: '" & URI & "'";
      end if;
      Controller.Driver := Get_Driver (URI (URI'First .. Pos - 1));
      if Controller.Driver = null then
         Log.Error ("No driver found for connection URI: {0}", URI);
         raise Connection_Error
           with "Driver '" & URI (URI'First .. Pos - 1) & "' not found";
      end if;

      Pos := Pos + 3;
      Slash_Pos := Index (URI, "/", Pos);
      if Slash_Pos < Pos then
         Log.Error ("Invalid connection URI: {0}", URI);
         raise Connection_Error
           with "Invalid connection URI: '" & URI & "'";
      end if;

      --  Extract the server and port.
      Pos2 := Index (URI, ":", Pos);
      if Pos2 >= Pos then
         Controller.Server := To_Unbounded_String (URI (Pos .. Pos2 - 1));
         begin
            Controller.Port := Natural'Value (URI (Pos2 + 1 .. Slash_Pos - 1));

         exception
            when Constraint_Error =>
               Log.Error ("Invalid port in connection URI: {0}", URI);
               raise Connection_Error
                 with "Invalid port in connection URI: '" & URI & "'";
         end;
      else
         Controller.Port := 0;
         Controller.Server := To_Unbounded_String (URI (Pos .. Slash_Pos - 1));
      end if;

      --  Extract the database name.
      Pos := Index (URI, "?", Slash_Pos);
      if Pos - 1 > Slash_Pos + 1 then
         Controller.Database := To_Unbounded_String (URI (Slash_Pos + 1 .. Pos - 1));
      elsif Pos = 0 and Slash_Pos + 1 < URI'Last then
         Controller.Database := To_Unbounded_String (URI (Slash_Pos + 1 .. URI'Last));
      else
         Controller.Database := Null_Unbounded_String;
      end if;

      --  Parse the optional properties
      if Pos > Slash_Pos then
         while Pos < URI'Last loop
            Pos2 := Index (URI, "=", Pos + 1);
            if Pos2 > Pos then
               Next := Index (URI, "&", Pos2 + 1);
               if Next > 0 then
                  Controller.Properties.Set (URI (Pos + 1 .. Pos2 - 1),
                                             URI (Pos2 + 1 .. Next - 1));
                  Pos := Next;
               else
                  Controller.Properties.Set (URI (Pos + 1 .. Pos2 - 1),
                                             URI (Pos2 + 1 .. URI'Last));
                  Pos := URI'Last;
               end if;
            else
               Controller.Properties.Set (URI (Pos + 1 .. URI'Last), "");
               Pos := URI'Last;
            end if;
         end loop;
      end if;
   end Set_Connection;

   --  ------------------------------
   --  Set a property on the datasource for the driver.
   --  The driver can retrieve the property to configure and open
   --  the database connection.
   --  ------------------------------
   procedure Set_Property (Controller : in out Configuration;
                           Name       : in String;
                           Value      : in String) is
   begin
      Controller.Properties.Set (Name, Value);
   end Set_Property;

   --  ------------------------------
   --  Get a property from the datasource configuration.
   --  If the property does not exist, an empty string is returned.
   --  ------------------------------
   function Get_Property (Controller : in Configuration;
                          Name       : in String) return String is
   begin
      return Controller.Properties.Get (Name, "");
   end Get_Property;

   --  ------------------------------
   --  Get the server hostname.
   --  ------------------------------
   function Get_Server (Controller : in Configuration) return String is
   begin
      return To_String (Controller.Server);
   end Get_Server;

   --  ------------------------------
   --  Set the server hostname.
   --  ------------------------------
   procedure Set_Server (Controller : in out Configuration;
                         Server     : in String) is
   begin
      Controller.Server := To_Unbounded_String (Server);
   end Set_Server;

   --  ------------------------------
   --  Set the server port.
   --  ------------------------------
   procedure Set_Port (Controller : in out Configuration;
                       Port       : in Natural) is
   begin
      Controller.Port := Port;
   end Set_Port;

   --  ------------------------------
   --  Get the server port.
   --  ------------------------------
   function Get_Port (Controller : in Configuration) return Natural is
   begin
      return Controller.Port;
   end Get_Port;

   --  ------------------------------
   --  Set the database name.
   --  ------------------------------
   procedure Set_Database (Controller : in out Configuration;
                           Database   : in String) is
   begin
      Controller.Database := To_Unbounded_String (Database);
   end Set_Database;

   --  ------------------------------
   --  Get the database name.
   --  ------------------------------
   function Get_Database (Controller : in Configuration) return String is
   begin
      return To_String (Controller.Database);
   end Get_Database;

   --  ------------------------------
   --  Create a new connection using the configuration parameters.
   --  ------------------------------
   procedure Create_Connection (Config : in Configuration'Class;
                                Result : out Database_Connection_Access) is
   begin
      if Config.Driver = null then
         Log.Error ("No driver found for connection {0}", To_String (Config.URI));
         raise Connection_Error with "Data source is not initialized: driver not found";
      end if;
      Config.Driver.Create_Connection (Config, Result);
      Log.Info ("Created connection to '{0}' -> {1}", Config.URI, Result.Ident);

   exception
      when others =>
         Log.Info ("Failed to create connection to '{0}'", Config.URI);
         raise;

   end Create_Connection;

   package Driver_List is
     new Ada.Containers.Doubly_Linked_Lists (Element_Type => Driver_Access);

   Next_Index : Driver_Index := 1;
   Drivers    : Driver_List.List;

   --  ------------------------------
   --  Get the driver unique index.
   --  ------------------------------
   function Get_Driver_Index (D : in Driver) return Driver_Index is
   begin
      return D.Index;
   end Get_Driver_Index;

   --  ------------------------------
   --  Get the driver name.
   --  ------------------------------
   function Get_Driver_Name (D : in Driver) return String is
   begin
      return D.Name.all;
   end Get_Driver_Name;

   --  ------------------------------
   --  Register a database driver.
   --  ------------------------------
   procedure Register (Driver : in Driver_Access) is
   begin
      Log.Info ("Register driver {0}", Driver.Name.all);

      Driver_List.Prepend (Container => Drivers, New_Item => Driver);
      Driver.Index := Next_Index;
      Next_Index := Next_Index + 1;
   end Register;

   --  ------------------------------
   --  Load the database driver.
   --  ------------------------------
   procedure Load_Driver (Name : in String) is
      Lib    : constant String := "libada_ado_" & Name & Util.Systems.DLLs.Extension;
      Symbol : constant String := "ado__drivers__connections__" & Name & "__initialize";
      Handle : Util.Systems.DLLs.Handle;
      Addr   : System.Address;

   begin
      Log.Info ("Loading driver {0}", Lib);
      Handle := Util.Systems.DLLs.Load (Lib);
      Addr := Util.Systems.DLLs.Get_Symbol (Handle, Symbol);

      declare
         procedure Init;
         pragma Import (C, Init);
         for Init'Address use Addr;
      begin
         Init;
      end;
   exception
      when Util.Systems.DLLs.Not_Found =>
         Log.Error ("Driver for {0} was loaded but does not define the initialization symbol",
                    Name);

      when E : Util.Systems.DLLs.Load_Error =>
         Log.Error ("Driver for {0} was not found: {1}",
                    Name, Ada.Exceptions.Exception_Message (E));

   end Load_Driver;

   --  ------------------------------
   --  Get a database driver given its name.
   --  ------------------------------
   function Get_Driver (Name : in String) return Driver_Access is
   begin
      Log.Info ("Get driver {0}", Name);

      for Retry in 0 .. 2 loop
         if Retry = 1 then
            ADO.Drivers.Initialize;
         elsif Retry = 2 then
            Load_Driver (Name);
         end if;
         declare
            Iter : Driver_List.Cursor := Driver_List.First (Drivers);
         begin
            while Driver_List.Has_Element (Iter) loop
               declare
                  D : constant Driver_Access := Driver_List.Element (Iter);
               begin
                  if Name = D.Name.all then
                     return D;
                  end if;
               end;
               Driver_List.Next (Iter);
            end loop;
         end;
      end loop;
      return null;
   end Get_Driver;

end ADO.Drivers.Connections;

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

with Util.Log.Loggers;
with Util.Systems.DLLs;

with System;
with Ada.Strings.Fixed;
with Ada.Containers.Doubly_Linked_Lists;
with Ada.Exceptions;

package body ADO.Drivers.Connections is

   use Ada.Strings.Fixed;

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("ADO.Drivers.Connections");

   --  Load the database driver.
   procedure Load_Driver (Name : in String);

   --  ------------------------------
   --  Set the connection URL to connect to the database.
   --  The driver connection is a string of the form:
   --
   --   driver://[host][:port]/[database][?property1][=value1]...
   --
   --  If the string is invalid or if the driver cannot be found,
   --  the Connection_Error exception is raised.
   --  ------------------------------
   procedure Set_Connection (Controller : in out Configuration;
                             URI        : in String) is

      Pos, Pos2, Slash_Pos, Next : Natural;
   begin
      Log.Info ("Set connection URI: {0}", URI);

      Controller.URI := To_Unbounded_String (URI);
      Pos := Index (URI, "://");
      if Pos <= 1 then
         Log.Error ("Invalid connection URI: {0}", URI);
         raise Connection_Error
           with "Invalid URI: '" & URI & "'";
      end if;
      Controller.Driver := Get_Driver (URI (URI'First .. Pos - 1));
      if Controller.Driver = null then
         Log.Error ("No driver found for connection URI: {0}", URI);
         raise Connection_Error
           with "Driver '" & URI (URI'First .. Pos - 1) & "' not found";
      end if;

      Pos := Pos + 3;
      Slash_Pos := Index (URI, "/", Pos);
      if Slash_Pos < Pos then
         Log.Error ("Invalid connection URI: {0}", URI);
         raise Connection_Error
           with "Invalid connection URI: '" & URI & "'";
      end if;

      --  Extract the server and port.
      Pos2 := Index (URI, ":", Pos);
      if Pos2 >= Pos then
         Controller.Server := To_Unbounded_String (URI (Pos .. Pos2 - 1));
         begin
            Controller.Port := Natural'Value (URI (Pos2 + 1 .. Slash_Pos - 1));

         exception
            when Constraint_Error =>
               Log.Error ("Invalid port in connection URI: {0}", URI);
               raise Connection_Error
                 with "Invalid port in connection URI: '" & URI & "'";
         end;
      else
         Controller.Port := 0;
         Controller.Server := To_Unbounded_String (URI (Pos .. Slash_Pos - 1));
      end if;

      --  Extract the database name.
      Pos := Index (URI, "?", Slash_Pos);
      if Pos - 1 > Slash_Pos + 1 then
         Controller.Database := To_Unbounded_String (URI (Slash_Pos + 1 .. Pos - 1));
      elsif Pos = 0 and Slash_Pos + 1 < URI'Last then
         Controller.Database := To_Unbounded_String (URI (Slash_Pos + 1 .. URI'Last));
      else
         Controller.Database := Null_Unbounded_String;
      end if;

      --  Parse the optional properties
      if Pos > Slash_Pos then
         while Pos < URI'Last loop
            Pos2 := Index (URI, "=", Pos + 1);
            if Pos2 > Pos then
               Next := Index (URI, "&", Pos2 + 1);
               if Next > 0 then
                  Controller.Properties.Set (URI (Pos + 1 .. Pos2 - 1),
                                             URI (Pos2 + 1 .. Next - 1));
                  Pos := Next;
               else
                  Controller.Properties.Set (URI (Pos + 1 .. Pos2 - 1),
                                             URI (Pos2 + 1 .. URI'Last));
                  Pos := URI'Last;
               end if;
            else
               Controller.Properties.Set (URI (Pos + 1 .. URI'Last), "");
               Pos := URI'Last;
            end if;
         end loop;
      end if;
   end Set_Connection;

   --  ------------------------------
   --  Set a property on the datasource for the driver.
   --  The driver can retrieve the property to configure and open
   --  the database connection.
   --  ------------------------------
   procedure Set_Property (Controller : in out Configuration;
                           Name       : in String;
                           Value      : in String) is
   begin
      Controller.Properties.Set (Name, Value);
   end Set_Property;

   --  ------------------------------
   --  Get a property from the datasource configuration.
   --  If the property does not exist, an empty string is returned.
   --  ------------------------------
   function Get_Property (Controller : in Configuration;
                          Name       : in String) return String is
   begin
      return Controller.Properties.Get (Name, "");
   end Get_Property;

   --  ------------------------------
   --  Get the server hostname.
   --  ------------------------------
   function Get_Server (Controller : in Configuration) return String is
   begin
      return To_String (Controller.Server);
   end Get_Server;

   --  ------------------------------
   --  Set the server hostname.
   --  ------------------------------
   procedure Set_Server (Controller : in out Configuration;
                         Server     : in String) is
   begin
      Controller.Server := To_Unbounded_String (Server);
   end Set_Server;

   --  ------------------------------
   --  Set the server port.
   --  ------------------------------
   procedure Set_Port (Controller : in out Configuration;
                       Port       : in Natural) is
   begin
      Controller.Port := Port;
   end Set_Port;

   --  ------------------------------
   --  Get the server port.
   --  ------------------------------
   function Get_Port (Controller : in Configuration) return Natural is
   begin
      return Controller.Port;
   end Get_Port;

   --  ------------------------------
   --  Set the database name.
   --  ------------------------------
   procedure Set_Database (Controller : in out Configuration;
                           Database   : in String) is
   begin
      Controller.Database := To_Unbounded_String (Database);
   end Set_Database;

   --  ------------------------------
   --  Get the database name.
   --  ------------------------------
   function Get_Database (Controller : in Configuration) return String is
   begin
      return To_String (Controller.Database);
   end Get_Database;

   --  ------------------------------
   --  Get the database driver name.
   --  ------------------------------
   function Get_Driver (Controller : in Configuration) return String is
   begin
      if Controller.Driver /= null then
         return Get_Driver_Name (Controller.Driver.all);
      else
         return "";
      end if;
   end Get_Driver;

   --  ------------------------------
   --  Create a new connection using the configuration parameters.
   --  ------------------------------
   procedure Create_Connection (Config : in Configuration'Class;
                                Result : out Database_Connection_Access) is
   begin
      if Config.Driver = null then
         Log.Error ("No driver found for connection {0}", To_String (Config.URI));
         raise Connection_Error with "Data source is not initialized: driver not found";
      end if;
      Config.Driver.Create_Connection (Config, Result);
      Log.Info ("Created connection to '{0}' -> {1}", Config.URI, Result.Ident);

   exception
      when others =>
         Log.Info ("Failed to create connection to '{0}'", Config.URI);
         raise;

   end Create_Connection;

   package Driver_List is
     new Ada.Containers.Doubly_Linked_Lists (Element_Type => Driver_Access);

   Next_Index : Driver_Index := 1;
   Drivers    : Driver_List.List;

   --  ------------------------------
   --  Get the driver unique index.
   --  ------------------------------
   function Get_Driver_Index (D : in Driver) return Driver_Index is
   begin
      return D.Index;
   end Get_Driver_Index;

   --  ------------------------------
   --  Get the driver name.
   --  ------------------------------
   function Get_Driver_Name (D : in Driver) return String is
   begin
      return D.Name.all;
   end Get_Driver_Name;

   --  ------------------------------
   --  Register a database driver.
   --  ------------------------------
   procedure Register (Driver : in Driver_Access) is
   begin
      Log.Info ("Register driver {0}", Driver.Name.all);

      Driver_List.Prepend (Container => Drivers, New_Item => Driver);
      Driver.Index := Next_Index;
      Next_Index := Next_Index + 1;
   end Register;

   --  ------------------------------
   --  Load the database driver.
   --  ------------------------------
   procedure Load_Driver (Name : in String) is
      Lib    : constant String := "libada_ado_" & Name & Util.Systems.DLLs.Extension;
      Symbol : constant String := "ado__drivers__connections__" & Name & "__initialize";
      Handle : Util.Systems.DLLs.Handle;
      Addr   : System.Address;

   begin
      Log.Info ("Loading driver {0}", Lib);
      Handle := Util.Systems.DLLs.Load (Lib);
      Addr := Util.Systems.DLLs.Get_Symbol (Handle, Symbol);

      declare
         procedure Init;
         pragma Import (C, Init);
         for Init'Address use Addr;
      begin
         Init;
      end;
   exception
      when Util.Systems.DLLs.Not_Found =>
         Log.Error ("Driver for {0} was loaded but does not define the initialization symbol",
                    Name);

      when E : Util.Systems.DLLs.Load_Error =>
         Log.Error ("Driver for {0} was not found: {1}",
                    Name, Ada.Exceptions.Exception_Message (E));

   end Load_Driver;

   --  ------------------------------
   --  Get a database driver given its name.
   --  ------------------------------
   function Get_Driver (Name : in String) return Driver_Access is
   begin
      Log.Info ("Get driver {0}", Name);

      for Retry in 0 .. 2 loop
         if Retry = 1 then
            ADO.Drivers.Initialize;
         elsif Retry = 2 then
            Load_Driver (Name);
         end if;
         declare
            Iter : Driver_List.Cursor := Driver_List.First (Drivers);
         begin
            while Driver_List.Has_Element (Iter) loop
               declare
                  D : constant Driver_Access := Driver_List.Element (Iter);
               begin
                  if Name = D.Name.all then
                     return D;
                  end if;
               end;
               Driver_List.Next (Iter);
            end loop;
         end;
      end loop;
      return null;
   end Get_Driver;

end ADO.Drivers.Connections;

Implement the Get_Driver function

Implement the Get_Driver function


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

--  == Buffered Streams ==
--  The `Output_Buffer_Stream` and `Input_Buffer_Stream` implement an output
--  and input stream respectively which manages an output or input buffer.  The data is
--  first written to the buffer and when the buffer is full or flushed, it gets written
--  to the target output stream.
--
--  The `Output_Buffer_Stream` must be initialized to indicate the buffer size as well
--  as the target output stream onto which the data will be flushed.  For example, a
--  pipe stream could be created and configured to use the buffer as follows:
--
--    with Util.Streams.Buffered;
--    with Util.Streams.Pipes;
--    ...
--       Pipe   : aliased Util.Streams.Pipes.Pipe_Stream;
--       Buffer : Util.Streams.Buffered.Output_Buffer_Stream;
--       ...
--          Buffer.Initialize (Output => Pipe'Access,
--                             Size => 1024);
--
--  In this example, the buffer of 1024 bytes is configured to flush its content to the
--  pipe input stream so that what is written to the buffer will be received as input by
--  the program.
--  The `Output_Buffer_Stream` provides write operation that deal only with binary data
--  (`Stream_Element`).  To write text, it is best to use the `Print_Stream` type from
--  the `Util.Streams.Texts` package as it extends the `Output_Buffer_Stream` and provides
--  several operations to write character and strings.
--
--  The `Input_Buffer_Stream` must also be initialized to also indicate the buffer size
--  and either an input stream or an input content.  When configured, the input stream is used
--  to fill the input stream buffer.  The buffer configuration is very similar as the
--  output stream:
--
--    with Util.Streams.Buffered;
--    with Util.Streams.Pipes;
--    ...
--       Pipe   : aliased Util.Streams.Pipes.Pipe_Stream;
--       Buffer : Util.Streams.Buffered.Input_Buffer_Stream;
--       ...
--          Buffer.Initialize (Input => Pipe'Access, Size => 1024);
--
--  In this case, the buffer of 1024 bytes is filled by reading the pipe stream, and thus
--  getting the program's output.
package Util.Streams.Buffered is

   pragma Preelaborate;

   type Buffer_Access is access Ada.Streams.Stream_Element_Array;

   --  -----------------------
   --  Output buffer stream
   --  -----------------------
   --  The Output_Buffer_Stream is an output stream which uses
   --  an intermediate buffer to write the data.
   --
   --  It is necessary to call Flush to make sure the data
   --  is written to the target stream.  The Flush operation will
   --  be called when finalizing the output buffer stream.
   type Output_Buffer_Stream is limited new Ada.Finalization.Limited_Controlled
     and Output_Stream with private;

   --  Initialize the stream to write on the given streams.
   --  An internal buffer is allocated for writing the stream.
   procedure Initialize (Stream  : in out Output_Buffer_Stream;
                         Output  : access Output_Stream'Class;
                         Size    : in Positive);

   --  Initialize the stream with a buffer of Size bytes.
   procedure Initialize (Stream  : in out Output_Buffer_Stream;
                         Size    : in Positive);

   --  Close the sink.
   overriding
   procedure Close (Stream : in out Output_Buffer_Stream);

   --  Get the direct access to the buffer.
   function Get_Buffer (Stream : in Output_Buffer_Stream) return Buffer_Access;

   --  Write the buffer array to the output stream.
   overriding
   procedure Write (Stream : in out Output_Buffer_Stream;
                    Buffer : in Ada.Streams.Stream_Element_Array);

   --  Flush the buffer by writing on the output stream.
   --  Raises Data_Error if there is no output stream.
   overriding
   procedure Flush (Stream : in out Output_Buffer_Stream);

   --  Flush the buffer in the <tt>Into</tt> array and return the index of the
   --  last element (inclusive) in <tt>Last</tt>.
   procedure Flush (Stream : in out Output_Buffer_Stream;
                    Into   : out Ada.Streams.Stream_Element_Array;
                    Last   : out Ada.Streams.Stream_Element_Offset);

   --  Flush the buffer stream to the unbounded string.
   procedure Flush (Stream : in out Output_Buffer_Stream;
                    Into   : out Ada.Strings.Unbounded.Unbounded_String);

   --  Flush the stream and release the buffer.
   overriding
   procedure Finalize (Stream : in out Output_Buffer_Stream);

   --  Get the number of element in the stream.
   function Get_Size (Stream : in Output_Buffer_Stream) return Natural;

   type Input_Buffer_Stream is limited new Input_Stream with private;

   --  Initialize the stream to read from the string.
   procedure Initialize (Stream  : in out Input_Buffer_Stream;
                         Content : in String);

   --  Initialize the stream to read the given streams.
   procedure Initialize (Stream  : in out Input_Buffer_Stream;
                         Input   : access Input_Stream'Class;
                         Size    : in Positive);

   --  Initialize the stream from the buffer created for an output stream.
   procedure Initialize (Stream  : in out Input_Buffer_Stream;
                         From    : in out Output_Buffer_Stream'Class);

   --  Fill the buffer by reading the input stream.
   --  Raises Data_Error if there is no input stream;
   procedure Fill (Stream : in out Input_Buffer_Stream);

   --  Read one character from the input stream.
   procedure Read (Stream : in out Input_Buffer_Stream;
                   Char   : out Character);

   --  Read into the buffer as many bytes as possible and return in
   --  last the position of the last byte read.
   overriding
   procedure Read (Stream : in out Input_Buffer_Stream;
                   Into   : out Ada.Streams.Stream_Element_Array;
                   Last   : out Ada.Streams.Stream_Element_Offset);

   --  Read into the buffer as many bytes as possible and return in
   --  last the position of the last byte read.
   procedure Read (Stream : in out Input_Buffer_Stream;
                   Into   : in out Ada.Strings.Unbounded.Unbounded_String);

   --  Returns True if the end of the stream is reached.
   function Is_Eof (Stream : in Input_Buffer_Stream) return Boolean;

private

   use Ada.Streams;

   type Output_Buffer_Stream is limited new Ada.Finalization.Limited_Controlled
     and Output_Stream with record
      --  The buffer where the data is written before being flushed.
      Buffer      : Buffer_Access := null;

      --  The next write position within the buffer.
      Write_Pos   : Stream_Element_Offset := 0;

      --  The next read position within the buffer.
      Read_Pos    : Stream_Element_Offset := 1;

      --  The last valid write position within the buffer.
      Last        : Stream_Element_Offset := 0;

      --  The output stream to use for flushing the buffer.
      Output      : access Output_Stream'Class;

      No_Flush    : Boolean := False;
   end record;

   type Input_Buffer_Stream is limited new Ada.Finalization.Limited_Controlled
     and Input_Stream with record
      --  The buffer where the data is written before being flushed.
      Buffer      : Buffer_Access := null;

      --  The next write position within the buffer.
      Write_Pos   : Stream_Element_Offset := 0;

      --  The next read position within the buffer.
      Read_Pos    : Stream_Element_Offset := 1;

      --  The last valid write position within the buffer.
      Last        : Stream_Element_Offset := 0;

      --  The input stream to use to fill the buffer.
      Input       : access Input_Stream'Class;

      --  Reached end of file when reading.
      Eof         : Boolean := False;
   end record;

   --  Release the buffer.
   overriding
   procedure Finalize (Object : in out Input_Buffer_Stream);

end Util.Streams.Buffered;

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

--  == Buffered Streams ==
--  The `Output_Buffer_Stream` and `Input_Buffer_Stream` implement an output
--  and input stream respectively which manages an output or input buffer.  The data is
--  first written to the buffer and when the buffer is full or flushed, it gets written
--  to the target output stream.
--
--  The `Output_Buffer_Stream` must be initialized to indicate the buffer size as well
--  as the target output stream onto which the data will be flushed.  For example, a
--  pipe stream could be created and configured to use the buffer as follows:
--
--    with Util.Streams.Buffered;
--    with Util.Streams.Pipes;
--    ...
--       Pipe   : aliased Util.Streams.Pipes.Pipe_Stream;
--       Buffer : Util.Streams.Buffered.Output_Buffer_Stream;
--       ...
--          Buffer.Initialize (Output => Pipe'Access,
--                             Size => 1024);
--
--  In this example, the buffer of 1024 bytes is configured to flush its content to the
--  pipe input stream so that what is written to the buffer will be received as input by
--  the program.
--  The `Output_Buffer_Stream` provides write operation that deal only with binary data
--  (`Stream_Element`).  To write text, it is best to use the `Print_Stream` type from
--  the `Util.Streams.Texts` package as it extends the `Output_Buffer_Stream` and provides
--  several operations to write character and strings.
--
--  The `Input_Buffer_Stream` must also be initialized to also indicate the buffer size
--  and either an input stream or an input content.  When configured, the input stream is used
--  to fill the input stream buffer.  The buffer configuration is very similar as the
--  output stream:
--
--    with Util.Streams.Buffered;
--    with Util.Streams.Pipes;
--    ...
--       Pipe   : aliased Util.Streams.Pipes.Pipe_Stream;
--       Buffer : Util.Streams.Buffered.Input_Buffer_Stream;
--       ...
--          Buffer.Initialize (Input => Pipe'Access, Size => 1024);
--
--  In this case, the buffer of 1024 bytes is filled by reading the pipe stream, and thus
--  getting the program's output.
package Util.Streams.Buffered is

   pragma Preelaborate;

   type Buffer_Access is access Ada.Streams.Stream_Element_Array;

   --  -----------------------
   --  Output buffer stream
   --  -----------------------
   --  The Output_Buffer_Stream is an output stream which uses
   --  an intermediate buffer to write the data.
   --
   --  It is necessary to call Flush to make sure the data
   --  is written to the target stream.  The Flush operation will
   --  be called when finalizing the output buffer stream.
   type Output_Buffer_Stream is limited new Ada.Finalization.Limited_Controlled
     and Output_Stream with private;

   --  Initialize the stream to write on the given streams.
   --  An internal buffer is allocated for writing the stream.
   procedure Initialize (Stream  : in out Output_Buffer_Stream;
                         Output  : access Output_Stream'Class;
                         Size    : in Positive);

   --  Initialize the stream with a buffer of Size bytes.
   procedure Initialize (Stream  : in out Output_Buffer_Stream;
                         Size    : in Positive);

   --  Close the sink.
   overriding
   procedure Close (Stream : in out Output_Buffer_Stream);

   --  Get the direct access to the buffer.
   function Get_Buffer (Stream : in Output_Buffer_Stream) return Buffer_Access;

   --  Write the buffer array to the output stream.
   overriding
   procedure Write (Stream : in out Output_Buffer_Stream;
                    Buffer : in Ada.Streams.Stream_Element_Array);

   --  Flush the buffer by writing on the output stream.
   --  Raises Data_Error if there is no output stream.
   overriding
   procedure Flush (Stream : in out Output_Buffer_Stream);

   --  Flush the buffer in the <tt>Into</tt> array and return the index of the
   --  last element (inclusive) in <tt>Last</tt>.
   procedure Flush (Stream : in out Output_Buffer_Stream;
                    Into   : out Ada.Streams.Stream_Element_Array;
                    Last   : out Ada.Streams.Stream_Element_Offset);

   --  Flush the buffer stream to the unbounded string.
   procedure Flush (Stream : in out Output_Buffer_Stream;
                    Into   : out Ada.Strings.Unbounded.Unbounded_String);

   --  Flush the stream and release the buffer.
   overriding
   procedure Finalize (Stream : in out Output_Buffer_Stream);

   --  Get the number of element in the stream.
   function Get_Size (Stream : in Output_Buffer_Stream) return Natural;

   type Input_Buffer_Stream is limited new Input_Stream with private;

   --  Initialize the stream to read from the string.
   procedure Initialize (Stream  : in out Input_Buffer_Stream;
                         Content : in String);

   --  Initialize the stream to read the given streams.
   procedure Initialize (Stream  : in out Input_Buffer_Stream;
                         Input   : access Input_Stream'Class;
                         Size    : in Positive);

   --  Initialize the stream from the buffer created for an output stream.
   procedure Initialize (Stream  : in out Input_Buffer_Stream;
                         From    : in out Output_Buffer_Stream'Class);

   --  Fill the buffer by reading the input stream.
   --  Raises Data_Error if there is no input stream;
   procedure Fill (Stream : in out Input_Buffer_Stream);

   --  Read one character from the input stream.
   procedure Read (Stream : in out Input_Buffer_Stream;
                   Char   : out Character);

   procedure Read (Stream : in out Input_Buffer_Stream;
                   Value  : out Ada.Streams.Stream_Element);

   procedure Read (Stream : in out Input_Buffer_Stream;
                   Char   : out Wide_Wide_Character);

   --  Read into the buffer as many bytes as possible and return in
   --  last the position of the last byte read.
   overriding
   procedure Read (Stream : in out Input_Buffer_Stream;
                   Into   : out Ada.Streams.Stream_Element_Array;
                   Last   : out Ada.Streams.Stream_Element_Offset);

   --  Read into the buffer as many bytes as possible and return in
   --  last the position of the last byte read.
   procedure Read (Stream : in out Input_Buffer_Stream;
                   Into   : in out Ada.Strings.Unbounded.Unbounded_String);

   procedure Read (Stream : in out Input_Buffer_Stream;
                   Into   : in out Ada.Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String);

   --  Returns True if the end of the stream is reached.
   function Is_Eof (Stream : in Input_Buffer_Stream) return Boolean;

private

   use Ada.Streams;

   type Output_Buffer_Stream is limited new Ada.Finalization.Limited_Controlled
     and Output_Stream with record
      --  The buffer where the data is written before being flushed.
      Buffer      : Buffer_Access := null;

      --  The next write position within the buffer.
      Write_Pos   : Stream_Element_Offset := 0;

      --  The next read position within the buffer.
      Read_Pos    : Stream_Element_Offset := 1;

      --  The last valid write position within the buffer.
      Last        : Stream_Element_Offset := 0;

      --  The output stream to use for flushing the buffer.
      Output      : access Output_Stream'Class;

      No_Flush    : Boolean := False;
   end record;

   type Input_Buffer_Stream is limited new Ada.Finalization.Limited_Controlled
     and Input_Stream with record
      --  The buffer where the data is written before being flushed.
      Buffer      : Buffer_Access := null;

      --  The next write position within the buffer.
      Write_Pos   : Stream_Element_Offset := 0;

      --  The next read position within the buffer.
      Read_Pos    : Stream_Element_Offset := 1;

      --  The last valid write position within the buffer.
      Last        : Stream_Element_Offset := 0;

      --  The input stream to use to fill the buffer.
      Input       : access Input_Stream'Class;

      --  Reached end of file when reading.
      Eof         : Boolean := False;
   end record;

   --  Release the buffer.
   overriding
   procedure Finalize (Object : in out Input_Buffer_Stream);

end Util.Streams.Buffered;

Declare new Read procedures to read UTF-8 sequences in Wide_Wide character and string