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

------------------------------------------------------------------------------
-- IMPLEMENTATION NOTE:                                                     --
-- In case of synchronized callbacks (same Origin and Period), there is a   --
-- collision on the internal map key. Since it is not expected to happen    --
-- often, a simple but not-so-efficient solution is used:                   --
-- When a collision is encountered, the callback is replaced by an          --
-- Event_List callback seeded with the existing callback and the new one.   --
-- When removing a callback, if it's not found directly, and second linear  --
-- is performed, looking for Event_List objects and removing it from them.  --
------------------------------------------------------------------------------

package body Natools.Cron is

   function Create_Event_List
     (Ref_1, Ref_2 : Callback_Refs.Reference)
      return Callback_Refs.Reference;
      --  Create an Event_List object containing Ref_1 and Ref_2,
      --  and return a reference to it.

   ------------------------
   -- Helper Subprograms --
   ------------------------

   function "<" (Left, Right : Periodic_Time) return Boolean is
      use type Ada.Calendar.Time;
   begin
      return Left.Origin < Right.Origin
        or else (Left.Origin = Right.Origin
           and then Left.Period < Right.Period);
   end "<";

   function Create_Event_List
     (Ref_1, Ref_2 : Callback_Refs.Reference)
      return Callback_Refs.Reference
   is
      function Create return Callback'Class;

      function Create return Callback'Class is
         Result : Event_List;
      begin
         Result.Append (Ref_1);
         Result.Append (Ref_2);
         return Result;
      end Create;
   begin
      return Callback_Refs.Create (Create'Access);
   end Create_Event_List;

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

   function Create
     (Time : in Periodic_Time;
      Callback : in Cron.Callback'Class)
     return Cron_Entry is
   begin
      return Result : Cron_Entry do
         Result.Set (Time, Callback);
      end return;
   end Create;

   function Create
     (Period : in Duration;
      Callback : in Cron.Callback'Class)
     return Cron_Entry is
   begin
      return Result : Cron_Entry do
         Result.Set (Period, Callback);
      end return;
   end Create;

   procedure Set
     (Self : in out Cron_Entry;
      Time : in Periodic_Time;
      Callback : in Cron.Callback'Class)
   is
      function Create return Cron.Callback'Class;

      function Create return Cron.Callback'Class is
      begin
         return Callback;
      end Create;
   begin
      Self.Reset;
      Self.Callback.Replace (Create'Access);
      Database.Insert (Time, Self.Callback);
   end Set;

   procedure Set
     (Self : in out Cron_Entry;
      Period : in Duration;
      Callback : in Cron.Callback'Class) is
   begin
      Set (Self, (Ada.Calendar.Clock, Period), Callback);
   end Set;

   overriding procedure Finalize (Object : in out Cron_Entry) is
   begin
      if not Object.Callback.Is_Empty then
         Object.Reset;
      end if;
   end Finalize;

   procedure Reset (Self : in out Cron_Entry) is
   begin
      if not Self.Callback.Is_Empty then
         Database.Remove (Self.Callback);
         Self.Callback.Reset;
      end if;
   end Reset;

   ------------------------
   -- Protected Database --
   ------------------------

   protected body Database is
      procedure Insert
        (Time : in Periodic_Time;
         Callback : in Callback_Refs.Reference)
      is
         use type Ada.Calendar.Time;

         Now : constant Ada.Calendar.Time := Ada.Calendar.Clock;
         Actual_Time : Periodic_Time := Time;
      begin
         while Actual_Time.Origin < Now loop
            Actual_Time.Origin := Actual_Time.Origin + Actual_Time.Period;
         end loop;

         if Map.Is_Empty then
            if Global_Worker /= null and then Global_Worker.all'Terminated then
               Unchecked_Free (Global_Worker);
            end if;

            if Global_Worker = null then
               Global_Worker := new Worker;
            end if;
         else
            if Actual_Time < Map.First_Key then
               First_Changed := True;
            end if;
         end if;

         declare
            Position : Entry_Maps.Cursor;
            Inserted : Boolean;
            Previous : Callback_Refs.Reference;
         begin
            Map.Insert (Actual_Time, Callback, Position, Inserted);

            if not Inserted then
               Previous := Entry_Maps.Element (Position);

               if Previous.Update.Data.all in Event_List then
                  Append
                    (Event_List (Previous.Update.Data.all),
                     Callback);
               else
                  Map.Replace_Element
                    (Position,
                     Create_Event_List (Previous, Callback));
               end if;
            end if;
         end;
      end Insert;

      procedure Remove (Callback : in Callback_Refs.Reference) is
         use type Callback_Refs.Reference;

         Cursor : Entry_Maps.Cursor := Map.First;
         Is_First : Boolean := True;
      begin
         while Entry_Maps.Has_Element (Cursor) loop
            if Entry_Maps.Element (Cursor) = Callback then
               Map.Delete (Cursor);

               if Is_First then
                  First_Changed := True;
               end if;

               return;
            end if;

            Entry_Maps.Next (Cursor);
            Is_First := False;
         end loop;

         Is_First := True;
         Cursor := Map.First;
         while Entry_Maps.Has_Element (Cursor) loop
            if Entry_Maps.Element (Cursor).Update.Data.all in Event_List then
               declare
                  Mutator : constant Callback_Refs.Mutator
                    := Entry_Maps.Element (Cursor).Update;
                  List : Event_List renames Event_List (Mutator.Data.all);
                  Removed : Boolean;
               begin
                  List.Remove (Callback, Removed);

                  if Removed then
                     if List.Is_Empty then
                        Map.Delete (Cursor);

                        if Is_First then
                           First_Changed := True;
                        end if;
                     end if;

                     return;
                  end if;
               end;
            end if;

            Entry_Maps.Next (Cursor);
            Is_First := False;
         end loop;
      end Remove;

      procedure Update (Callback : in Callback_Refs.Reference) is
         use type Callback_Refs.Reference;
         Cursor : Entry_Maps.Cursor := Map.First;
      begin
         Search :
         while Entry_Maps.Has_Element (Cursor) loop
            if Entry_Maps.Element (Cursor) = Callback then
               declare
                  Old_Time : constant Periodic_Time := Entry_Maps.Key (Cursor);
               begin
                  Map.Delete (Cursor);
                  Insert (Old_Time, Callback);
               end;

               exit Search;
            end if;

            Entry_Maps.Next (Cursor);
         end loop Search;
      end Update;

      procedure Get_First
        (Time : out Periodic_Time;
         Callback : out Callback_Refs.Reference)
      is
         Cursor : constant Entry_Maps.Cursor := Map.First;
      begin
         if Entry_Maps.Has_Element (Cursor) then
            Time := Entry_Maps.Key (Cursor);
            Callback := Entry_Maps.Element (Cursor);
         else
            Callback := Callback_Refs.Null_Reference;
         end if;

         First_Changed := False;
      end Get_First;

      entry Update_Notification when First_Changed is
      begin
         null;
      end Update_Notification;

   end Database;

   -----------------
   -- Worker Task --
   -----------------

   task body Worker is
      Time : Periodic_Time;
      Callback : Callback_Refs.Reference;
      Waiting : Boolean;
   begin
      Main :
      loop
         Waiting := True;

         Wait_Loop :
         while Waiting loop
            Database.Get_First (Time, Callback);
            exit Main when Callback.Is_Empty;

            select
               Database.Update_Notification;
            or
               delay until Time.Origin;
               Waiting := False;
            end select;
         end loop Wait_Loop;

         Callback.Update.Data.Run;
         Database.Update (Callback);
      end loop Main;
   end Worker;

   ----------------
   -- Event List --
   ----------------

   overriding procedure Run (Self : in out Event_List) is
   begin
      for Ref of Self.List loop
         Ref.Update.Data.Run;
      end loop;
   end Run;

   procedure Append
     (Self : in out Event_List;
      Ref : in Callback_Refs.Reference) is
   begin
      Self.List.Append (Ref);
   end Append;

   procedure Remove
     (Self : in out Event_List;
      Ref : in Callback_Refs.Reference;
      Removed : out Boolean)
   is
      use type Callback_Refs.Reference;
      Cursor : Event_Lists.Cursor := Self.List.First;
   begin
      Removed := False;

      while Event_Lists.Has_Element (Cursor) loop
         if Event_Lists.Element (Cursor) = Ref then
            Self.List.Delete (Cursor);
            Removed := True;
            return;
         end if;

         Event_Lists.Next (Cursor);
      end loop;
   end Remove;

   function Is_Empty (Self : Event_List) return Boolean is
   begin
      return Self.List.Is_Empty;
   end Is_Empty;

end Natools.Cron;

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

------------------------------------------------------------------------------
-- IMPLEMENTATION NOTE:                                                     --
-- In case of synchronized callbacks (same Origin and Period), there is a   --
-- collision on the internal map key. Since it is not expected to happen    --
-- often, a simple but not-so-efficient solution is used:                   --
-- When a collision is encountered, the callback is replaced by an          --
-- Event_List callback seeded with the existing callback and the new one.   --
-- When removing a callback, if it's not found directly, and second linear  --
-- is performed, looking for Event_List objects and removing it from them.  --
------------------------------------------------------------------------------

package body Natools.Cron is

   function Create_Event_List
     (Ref_1, Ref_2 : Callback_Refs.Reference)
      return Callback_Refs.Reference;
      --  Create an Event_List object containing Ref_1 and Ref_2,
      --  and return a reference to it.

   ------------------------
   -- Helper Subprograms --
   ------------------------

   function "<" (Left, Right : Periodic_Time) return Boolean is
      use type Ada.Calendar.Time;
   begin
      return Left.Origin < Right.Origin
        or else (Left.Origin = Right.Origin
           and then Left.Period < Right.Period);
   end "<";

   function Create_Event_List
     (Ref_1, Ref_2 : Callback_Refs.Reference)
      return Callback_Refs.Reference
   is
      function Create return Callback'Class;

      function Create return Callback'Class is
         Result : Event_List;
      begin
         Result.Append (Ref_1);
         Result.Append (Ref_2);
         return Result;
      end Create;
   begin
      return Callback_Refs.Create (Create'Access);
   end Create_Event_List;

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

   function Create
     (Time : in Periodic_Time;
      Callback : in Cron.Callback'Class)
     return Cron_Entry is
   begin
      return Result : Cron_Entry do
         Result.Set (Time, Callback);
      end return;
   end Create;

   function Create
     (Period : in Duration;
      Callback : in Cron.Callback'Class)
     return Cron_Entry is
   begin
      return Result : Cron_Entry do
         Result.Set (Period, Callback);
      end return;
   end Create;

   procedure Set
     (Self : in out Cron_Entry;
      Time : in Periodic_Time;
      Callback : in Cron.Callback'Class)
   is
      function Create return Cron.Callback'Class;

      function Create return Cron.Callback'Class is
      begin
         return Callback;
      end Create;
   begin
      Self.Reset;
      Self.Callback.Replace (Create'Access);
      Database.Insert (Time, Self.Callback);
   end Set;

   procedure Set
     (Self : in out Cron_Entry;
      Period : in Duration;
      Callback : in Cron.Callback'Class) is
   begin
      Set (Self, (Ada.Calendar.Clock, Period), Callback);
   end Set;

   overriding procedure Finalize (Object : in out Cron_Entry) is
   begin
      if not Object.Callback.Is_Empty then
         Object.Reset;
      end if;
   end Finalize;

   procedure Reset (Self : in out Cron_Entry) is
   begin
      if not Self.Callback.Is_Empty then
         Database.Remove (Self.Callback);
         Self.Callback.Reset;
      end if;
   end Reset;

   ------------------------
   -- Protected Database --
   ------------------------

   protected body Database is
      procedure Insert
        (Time : in Periodic_Time;
         Callback : in Callback_Refs.Reference)
      is
         use type Ada.Calendar.Time;

         Now : constant Ada.Calendar.Time := Ada.Calendar.Clock;
         Actual_Time : Periodic_Time := Time;
      begin
         if Actual_Time.Period > 0.0 then
            while Actual_Time.Origin < Now loop
               Actual_Time.Origin := Actual_Time.Origin + Actual_Time.Period;
            end loop;
         end if;

         if Map.Is_Empty then
            if Global_Worker /= null and then Global_Worker.all'Terminated then
               Unchecked_Free (Global_Worker);
            end if;

            if Global_Worker = null then
               Global_Worker := new Worker;
            end if;
         else
            if Actual_Time < Map.First_Key then
               First_Changed := True;
            end if;
         end if;

         declare
            Position : Entry_Maps.Cursor;
            Inserted : Boolean;
            Previous : Callback_Refs.Reference;
         begin
            Map.Insert (Actual_Time, Callback, Position, Inserted);

            if not Inserted then
               Previous := Entry_Maps.Element (Position);

               if Previous.Update.Data.all in Event_List then
                  Append
                    (Event_List (Previous.Update.Data.all),
                     Callback);
               else
                  Map.Replace_Element
                    (Position,
                     Create_Event_List (Previous, Callback));
               end if;
            end if;
         end;
      end Insert;

      procedure Remove (Callback : in Callback_Refs.Reference) is
         use type Callback_Refs.Reference;

         Cursor : Entry_Maps.Cursor := Map.First;
         Is_First : Boolean := True;
      begin
         while Entry_Maps.Has_Element (Cursor) loop
            if Entry_Maps.Element (Cursor) = Callback then
               Map.Delete (Cursor);

               if Is_First then
                  First_Changed := True;
               end if;

               return;
            end if;

            Entry_Maps.Next (Cursor);
            Is_First := False;
         end loop;

         Is_First := True;
         Cursor := Map.First;
         while Entry_Maps.Has_Element (Cursor) loop
            if Entry_Maps.Element (Cursor).Update.Data.all in Event_List then
               declare
                  Mutator : constant Callback_Refs.Mutator
                    := Entry_Maps.Element (Cursor).Update;
                  List : Event_List renames Event_List (Mutator.Data.all);
                  Removed : Boolean;
               begin
                  List.Remove (Callback, Removed);

                  if Removed then
                     if List.Is_Empty then
                        Map.Delete (Cursor);

                        if Is_First then
                           First_Changed := True;
                        end if;
                     end if;

                     return;
                  end if;
               end;
            end if;

            Entry_Maps.Next (Cursor);
            Is_First := False;
         end loop;
      end Remove;

      procedure Update (Callback : in Callback_Refs.Reference) is
         use type Callback_Refs.Reference;
         Cursor : Entry_Maps.Cursor := Map.First;
      begin
         Search :
         while Entry_Maps.Has_Element (Cursor) loop
            if Entry_Maps.Element (Cursor) = Callback then
               declare
                  Old_Time : constant Periodic_Time := Entry_Maps.Key (Cursor);
               begin
                  Map.Delete (Cursor);

                  if Old_Time.Period > 0.0 then
                     Insert (Old_Time, Callback);
                  end if;
               end;

               exit Search;
            end if;

            Entry_Maps.Next (Cursor);
         end loop Search;
      end Update;

      procedure Get_First
        (Time : out Periodic_Time;
         Callback : out Callback_Refs.Reference)
      is
         Cursor : constant Entry_Maps.Cursor := Map.First;
      begin
         if Entry_Maps.Has_Element (Cursor) then
            Time := Entry_Maps.Key (Cursor);
            Callback := Entry_Maps.Element (Cursor);
         else
            Callback := Callback_Refs.Null_Reference;
         end if;

         First_Changed := False;
      end Get_First;

      entry Update_Notification when First_Changed is
      begin
         null;
      end Update_Notification;

   end Database;

   -----------------
   -- Worker Task --
   -----------------

   task body Worker is
      Time : Periodic_Time;
      Callback : Callback_Refs.Reference;
      Waiting : Boolean;
   begin
      Main :
      loop
         Waiting := True;

         Wait_Loop :
         while Waiting loop
            Database.Get_First (Time, Callback);
            exit Main when Callback.Is_Empty;

            select
               Database.Update_Notification;
            or
               delay until Time.Origin;
               Waiting := False;
            end select;
         end loop Wait_Loop;

         Callback.Update.Data.Run;
         Database.Update (Callback);
      end loop Main;
   end Worker;

   ----------------
   -- Event List --
   ----------------

   overriding procedure Run (Self : in out Event_List) is
   begin
      for Ref of Self.List loop
         Ref.Update.Data.Run;
      end loop;
   end Run;

   procedure Append
     (Self : in out Event_List;
      Ref : in Callback_Refs.Reference) is
   begin
      Self.List.Append (Ref);
   end Append;

   procedure Remove
     (Self : in out Event_List;
      Ref : in Callback_Refs.Reference;
      Removed : out Boolean)
   is
      use type Callback_Refs.Reference;
      Cursor : Event_Lists.Cursor := Self.List.First;
   begin
      Removed := False;

      while Event_Lists.Has_Element (Cursor) loop
         if Event_Lists.Element (Cursor) = Ref then
            Self.List.Delete (Cursor);
            Removed := True;
            return;
         end if;

         Event_Lists.Next (Cursor);
      end loop;
   end Remove;

   function Is_Empty (Self : Event_List) return Boolean is
   begin
      return Self.List.Is_Empty;
   end Is_Empty;

end Natools.Cron;

cron: use non-positive periods to mean non-repeating events


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

with MAT.Frames;
with MAT.Expressions.Parser;
package body MAT.Expressions is

   procedure Free is
     new Ada.Unchecked_Deallocation (Object => Node_Type,
                                     Name   => Node_Type_Access);

   --  Destroy recursively the node, releasing the storage.
   procedure Destroy (Node : in out Node_Type_Access);

   Resolver : Resolver_Type_Access;

   --  ------------------------------
   --  Create a NOT expression node.
   --  ------------------------------
   function Create_Not (Expr : in Expression_Type) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_NOT,
                                    Expr        => Expr.Node);
      Util.Concurrent.Counters.Increment (Expr.Node.Ref_Counter);
      return Result;
   end Create_Not;

   --  ------------------------------
   --  Create a AND expression node.
   --  ------------------------------
   function Create_And (Left  : in Expression_Type;
                        Right : in Expression_Type) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_AND,
                                    Left        => Left.Node,
                                    Right       => Right.Node);
      Util.Concurrent.Counters.Increment (Left.Node.Ref_Counter);
      Util.Concurrent.Counters.Increment (Right.Node.Ref_Counter);
      return Result;
   end Create_And;

   --  ------------------------------
   --  Create a OR expression node.
   --  ------------------------------
   function Create_Or (Left  : in Expression_Type;
                       Right : in Expression_Type) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_OR,
                                    Left        => Left.Node,
                                    Right       => Right.Node);
      Util.Concurrent.Counters.Increment (Left.Node.Ref_Counter);
      Util.Concurrent.Counters.Increment (Right.Node.Ref_Counter);
      return Result;
   end Create_Or;

   --  ------------------------------
   --  Create an INSIDE expression node.
   --  ------------------------------
   function Create_Inside (Name : in Ada.Strings.Unbounded.Unbounded_String;
                           Kind : in Inside_Type) return Expression_Type is
      Result : Expression_Type;
      Region : MAT.Memory.Region_Info;
   begin
      if Resolver /= null then
         case Kind is
            when INSIDE_REGION | INSIDE_DIRECT_REGION =>
               Region := Resolver.Find_Region (Ada.Strings.Unbounded.To_String (Name));

            when others =>
               Region := Resolver.Find_Symbol (Ada.Strings.Unbounded.To_String (Name));

         end case;
      end if;
      if Kind = INSIDE_DIRECT_REGION or Kind = INSIDE_DIRECT_FUNCTION then
         Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                       Kind        => N_IN_FUNC_DIRECT,
                                       Min_Addr    => Region.Start_Addr,
                                       Max_Addr    => Region.End_Addr);
      else
         Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                       Kind        => N_IN_FUNC,
                                       Min_Addr    => Region.Start_Addr,
                                       Max_Addr    => Region.End_Addr);
      end if;
      return Result;
   end Create_Inside;

   --  ------------------------------
   --  Create an size range expression node.
   --  ------------------------------
   function Create_Size (Min : in MAT.Types.Target_Size;
                         Max : in MAT.Types.Target_Size) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_RANGE_SIZE,
                                    Min_Size    => Min,
                                    Max_Size    => Max);
      return Result;
   end Create_Size;

   --  ------------------------------
   --  Create an addr range expression node.
   --  ------------------------------
   function Create_Addr (Min : in MAT.Types.Target_Addr;
                         Max : in MAT.Types.Target_Addr) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_HAS_ADDR,
                                    Min_Addr    => Min,
                                    Max_Addr    => Max);
      return Result;
   end Create_Addr;

   --  ------------------------------
   --  Create an time range expression node.
   --  ------------------------------
   function Create_Time (Min : in MAT.Types.Target_Tick_Ref;
                         Max : in MAT.Types.Target_Tick_Ref) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_RANGE_TIME,
                                    Min_Time    => Min,
                                    Max_Time    => Max);
      return Result;
   end Create_Time;

   --  ------------------------------
   --  Create a thread ID range expression node.
   --  ------------------------------
   function Create_Thread (Min : in MAT.Types.Target_Thread_Ref;
                           Max : in MAT.Types.Target_Thread_Ref) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_THREAD,
                                    Min_Thread  => Min,
                                    Max_Thread  => Max);
      return Result;
   end Create_Thread;

   --  ------------------------------
   --  Create a event type expression check.
   --  ------------------------------
   function Create_Event_Type (Event_Kind : in MAT.Events.Probe_Index_Type)
                               return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_TYPE,
                                    Event_Kind  => Event_Kind);
      return Result;
   end Create_Event_Type;

   --  ------------------------------
   --  Create an event ID range expression node.
   --  ------------------------------
   function Create_Event (Min : in MAT.Events.Event_Id_Type;
                          Max : in MAT.Events.Event_Id_Type) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_EVENT,
                                    Min_Event   => Min,
                                    Max_Event   => Max);
      return Result;
   end Create_Event;

   --  ------------------------------
   --  Create an expression node to keep allocation events which don't have any associated free.
   --  ------------------------------
   function Create_No_Free return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_NO_FREE);
      return Result;
   end Create_No_Free;

   --  ------------------------------
   --  Evaluate the expression to check if the memory slot described by the
   --  context is selected.  Returns True if the memory slot is selected.
   --  ------------------------------
   function Is_Selected (Node       : in Expression_Type;
                         Addr       : in MAT.Types.Target_Addr;
                         Allocation : in MAT.Memory.Allocation) return Boolean is
   begin
      if Node.Node = null then
         return True;
      else
         return Is_Selected (Node.Node.all, Addr, Allocation);
      end if;
   end Is_Selected;

   --  ------------------------------
   --  Evaluate the expression to check if the event described by the
   --  context is selected.  Returns True if the event is selected.
   --  ------------------------------
   function Is_Selected (Node       : in Expression_Type;
                         Event      : in MAT.Events.Target_Event_Type) return Boolean is
   begin
      if Node.Node = null then
         return True;
      else
         return Is_Selected (Node.Node.all, Event);
      end if;
   end Is_Selected;

   --  ------------------------------
   --  Evaluate the node against the context.  Returns True if the node expression
   --  selects the memory slot defined by the context.
   --  ------------------------------
   function Is_Selected (Node       : in Node_Type;
                         Addr       : in MAT.Types.Target_Addr;
                         Allocation : in MAT.Memory.Allocation) return Boolean is
      use type MAT.Types.Target_Size;
      use type MAT.Types.Target_Tick_Ref;
   begin
      case Node.Kind is
         when N_NOT =>
            return not Is_Selected (Node.Expr.all, Addr, Allocation);

         when N_AND =>
            return Is_Selected (Node.Left.all, Addr, Allocation)
              and then Is_Selected (Node.Right.all, Addr, Allocation);

         when N_OR =>
            return Is_Selected (Node.Left.all, Addr, Allocation)
              or else Is_Selected (Node.Right.all, Addr, Allocation);

         when N_RANGE_SIZE =>
            return Allocation.Size >= Node.Min_Size
              and Allocation.Size <= Node.Max_Size;

         when N_RANGE_ADDR =>
            return Addr >= Node.Min_Addr
              and Addr <= Node.Max_Addr;

         when N_RANGE_TIME =>
            return Allocation.Time >= Node.Min_Time
              and Allocation.Time <= Node.Max_Time;

         when others =>
            return False;

      end case;
   end Is_Selected;

   --  ------------------------------
   --  Evaluate the expression to check if the event described by the
   --  context is selected.  Returns True if the event is selected.
   --  ------------------------------
   function Is_Selected (Node       : in Node_Type;
                         Event      : in MAT.Events.Target_Event_Type) return Boolean is
      use type MAT.Types.Target_Size;
      use type MAT.Types.Target_Tick_Ref;
      use type MAT.Types.Target_Thread_Ref;
      use type MAT.Events.Event_Id_Type;
      use type MAT.Events.Probe_Index_Type;
   begin
      case Node.Kind is
         when N_NOT =>
            return not Is_Selected (Node.Expr.all, Event);

         when N_AND =>
            return Is_Selected (Node.Left.all, Event)
              and then Is_Selected (Node.Right.all, Event);

         when N_OR =>
            return Is_Selected (Node.Left.all, Event)
              or else Is_Selected (Node.Right.all, Event);

         when N_RANGE_SIZE =>
            return Event.Size >= Node.Min_Size
              and Event.Size <= Node.Max_Size;

         when N_RANGE_ADDR =>
            return Event.Addr >= Node.Min_Addr
              and Event.Addr <= Node.Max_Addr;

         when N_RANGE_TIME =>
            return Event.Time >= Node.Min_Time
              and Event.Time <= Node.Max_Time;

         when N_EVENT =>
            return Event.Id >= Node.Min_Event
              and Event.Id <= Node.Max_Event;

         when N_THREAD =>
            return Event.Thread >= Node.Min_Thread
              and Event.Thread <= Node.Max_Thread;

         when N_TYPE =>
            return Event.Index = Node.Event_Kind;

         when N_HAS_ADDR =>
            if Event.Index = MAT.Events.MSG_MALLOC
              or Event.Index = MAT.Events.MSG_REALLOC
            then
               return Event.Addr <= Node.Min_Addr and Event.Addr + Event.Size >= Node.Max_Addr;
            end if;
            return False;

         when N_NO_FREE =>
            if Event.Index = MAT.Events.MSG_MALLOC
              or Event.Index = MAT.Events.MSG_REALLOC
            then
               return Event.Next_Id = 0;
            else
               return False;
            end if;

         when N_IN_FUNC =>
            return MAT.Frames.In_Function (Event.Frame, Node.Min_Addr, Node.Max_Addr);

         when N_IN_FUNC_DIRECT =>
            return MAT.Frames.By_Function (Event.Frame, Node.Min_Addr, Node.Max_Addr);

         when others =>
            return False;

      end case;
   end Is_Selected;

   --  ------------------------------
   --  Parse the string and return the expression tree.
   --  ------------------------------
   function Parse (Expr     : in String;
                   Resolver : in Resolver_Type_Access) return Expression_Type is
   begin
      MAT.Expressions.Resolver := Resolver;
      return MAT.Expressions.Parser.Parse (Expr);
   end Parse;

   --  ------------------------------
   --  Destroy recursively the node, releasing the storage.
   --  ------------------------------
   procedure Destroy (Node : in out Node_Type_Access) is
      Release : Boolean;
   begin
      if Node /= null then
         Util.Concurrent.Counters.Decrement (Node.Ref_Counter, Release);
         if Release then
            case Node.Kind is
            when N_NOT =>
               Destroy (Node.Expr);

            when N_AND | N_OR =>
               Destroy (Node.Left);
               Destroy (Node.Right);

            when others =>
               null;
            end case;
            Free (Node);
         else
            Node := null;
         end if;
      end if;
   end Destroy;

   --  ------------------------------
   --  Release the reference and destroy the expression tree if it was the last reference.
   --  ------------------------------
   overriding
   procedure Finalize (Obj : in out Expression_Type) is
   begin
      if Obj.Node /= null then
         Destroy (Obj.Node);
      end if;
   end Finalize;

   --  ------------------------------
   --  Update the reference after an assignment.
   --  ------------------------------
   overriding
   procedure Adjust (Obj : in out Expression_Type) is
   begin
      if Obj.Node /= null then
         Util.Concurrent.Counters.Increment (Obj.Node.Ref_Counter);
      end if;
   end Adjust;

end MAT.Expressions;

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

with MAT.Frames;
with MAT.Expressions.Parser;
package body MAT.Expressions is

   procedure Free is
     new Ada.Unchecked_Deallocation (Object => Node_Type,
                                     Name   => Node_Type_Access);

   --  Destroy recursively the node, releasing the storage.
   procedure Destroy (Node : in out Node_Type_Access);

   Resolver : Resolver_Type_Access;

   --  ------------------------------
   --  Create a NOT expression node.
   --  ------------------------------
   function Create_Not (Expr : in Expression_Type) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_NOT,
                                    Expr        => Expr.Node);
      Util.Concurrent.Counters.Increment (Expr.Node.Ref_Counter);
      return Result;
   end Create_Not;

   --  ------------------------------
   --  Create a AND expression node.
   --  ------------------------------
   function Create_And (Left  : in Expression_Type;
                        Right : in Expression_Type) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_AND,
                                    Left        => Left.Node,
                                    Right       => Right.Node);
      Util.Concurrent.Counters.Increment (Left.Node.Ref_Counter);
      Util.Concurrent.Counters.Increment (Right.Node.Ref_Counter);
      return Result;
   end Create_And;

   --  ------------------------------
   --  Create a OR expression node.
   --  ------------------------------
   function Create_Or (Left  : in Expression_Type;
                       Right : in Expression_Type) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_OR,
                                    Left        => Left.Node,
                                    Right       => Right.Node);
      Util.Concurrent.Counters.Increment (Left.Node.Ref_Counter);
      Util.Concurrent.Counters.Increment (Right.Node.Ref_Counter);
      return Result;
   end Create_Or;

   --  ------------------------------
   --  Create an INSIDE expression node.
   --  ------------------------------
   function Create_Inside (Name : in Ada.Strings.Unbounded.Unbounded_String;
                           Kind : in Inside_Type) return Expression_Type is
      Result : Expression_Type;
      Region : MAT.Memory.Region_Info;
   begin
      if Resolver /= null then
         case Kind is
            when INSIDE_REGION | INSIDE_DIRECT_REGION =>
               Region := Resolver.Find_Region (Ada.Strings.Unbounded.To_String (Name));

            when others =>
               Region := Resolver.Find_Symbol (Ada.Strings.Unbounded.To_String (Name));

         end case;
      end if;
      if Kind = INSIDE_DIRECT_REGION or Kind = INSIDE_DIRECT_FUNCTION then
         Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                       Kind        => N_IN_FUNC_DIRECT,
                                       Min_Addr    => Region.Start_Addr,
                                       Max_Addr    => Region.End_Addr);
      else
         Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                       Kind        => N_IN_FUNC,
                                       Min_Addr    => Region.Start_Addr,
                                       Max_Addr    => Region.End_Addr);
      end if;
      return Result;
   end Create_Inside;

   --  ------------------------------
   --  Create an size range expression node.
   --  ------------------------------
   function Create_Size (Min : in MAT.Types.Target_Size;
                         Max : in MAT.Types.Target_Size) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_RANGE_SIZE,
                                    Min_Size    => Min,
                                    Max_Size    => Max);
      return Result;
   end Create_Size;

   --  ------------------------------
   --  Create an addr range expression node.
   --  ------------------------------
   function Create_Addr (Min : in MAT.Types.Target_Addr;
                         Max : in MAT.Types.Target_Addr) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_HAS_ADDR,
                                    Min_Addr    => Min,
                                    Max_Addr    => Max);
      return Result;
   end Create_Addr;

   --  ------------------------------
   --  Create an time range expression node.
   --  ------------------------------
   function Create_Time (Min : in MAT.Types.Target_Tick_Ref;
                         Max : in MAT.Types.Target_Tick_Ref) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_RANGE_TIME,
                                    Min_Time    => Min,
                                    Max_Time    => Max);
      return Result;
   end Create_Time;

   --  ------------------------------
   --  Create a thread ID range expression node.
   --  ------------------------------
   function Create_Thread (Min : in MAT.Types.Target_Thread_Ref;
                           Max : in MAT.Types.Target_Thread_Ref) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_THREAD,
                                    Min_Thread  => Min,
                                    Max_Thread  => Max);
      return Result;
   end Create_Thread;

   --  ------------------------------
   --  Create a event type expression check.
   --  ------------------------------
   function Create_Event_Type (Event_Kind : in MAT.Events.Probe_Index_Type)
                               return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_TYPE,
                                    Event_Kind  => Event_Kind);
      return Result;
   end Create_Event_Type;

   --  ------------------------------
   --  Create an event ID range expression node.
   --  ------------------------------
   function Create_Event (Min : in MAT.Events.Event_Id_Type;
                          Max : in MAT.Events.Event_Id_Type) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_EVENT,
                                    Min_Event   => Min,
                                    Max_Event   => Max);
      return Result;
   end Create_Event;

   --  ------------------------------
   --  Create an expression node to keep allocation events which don't have any associated free.
   --  ------------------------------
   function Create_No_Free return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_NO_FREE);
      return Result;
   end Create_No_Free;

   --  ------------------------------
   --  Evaluate the expression to check if the memory slot described by the
   --  context is selected.  Returns True if the memory slot is selected.
   --  ------------------------------
   function Is_Selected (Node       : in Expression_Type;
                         Addr       : in MAT.Types.Target_Addr;
                         Allocation : in MAT.Memory.Allocation) return Boolean is
   begin
      if Node.Node = null then
         return True;
      else
         return Is_Selected (Node.Node.all, Addr, Allocation);
      end if;
   end Is_Selected;

   --  ------------------------------
   --  Evaluate the expression to check if the event described by the
   --  context is selected.  Returns True if the event is selected.
   --  ------------------------------
   function Is_Selected (Node       : in Expression_Type;
                         Event      : in MAT.Events.Target_Event_Type) return Boolean is
   begin
      if Node.Node = null then
         return True;
      else
         return Is_Selected (Node.Node.all, Event);
      end if;
   end Is_Selected;

   --  ------------------------------
   --  Evaluate the node against the context.  Returns True if the node expression
   --  selects the memory slot defined by the context.
   --  ------------------------------
   function Is_Selected (Node       : in Node_Type;
                         Addr       : in MAT.Types.Target_Addr;
                         Allocation : in MAT.Memory.Allocation) return Boolean is
      use type MAT.Types.Target_Size;
      use type MAT.Types.Target_Tick_Ref;
   begin
      case Node.Kind is
         when N_NOT =>
            return not Is_Selected (Node.Expr.all, Addr, Allocation);

         when N_AND =>
            return Is_Selected (Node.Left.all, Addr, Allocation)
              and then Is_Selected (Node.Right.all, Addr, Allocation);

         when N_OR =>
            return Is_Selected (Node.Left.all, Addr, Allocation)
              or else Is_Selected (Node.Right.all, Addr, Allocation);

         when N_RANGE_SIZE =>
            return Allocation.Size >= Node.Min_Size
              and Allocation.Size <= Node.Max_Size;

         when N_RANGE_ADDR =>
            return Addr >= Node.Min_Addr
              and Addr <= Node.Max_Addr;

         when N_RANGE_TIME =>
            return Allocation.Time >= Node.Min_Time
              and Allocation.Time <= Node.Max_Time;

         when N_IN_FUNC =>
            return MAT.Frames.In_Function (Allocation.Frame, Node.Min_Addr, Node.Max_Addr);

         when N_IN_FUNC_DIRECT =>
            return MAT.Frames.By_Function (Allocation.Frame, Node.Min_Addr, Node.Max_Addr);

         when others =>
            return False;

      end case;
   end Is_Selected;

   --  ------------------------------
   --  Evaluate the expression to check if the event described by the
   --  context is selected.  Returns True if the event is selected.
   --  ------------------------------
   function Is_Selected (Node       : in Node_Type;
                         Event      : in MAT.Events.Target_Event_Type) return Boolean is
      use type MAT.Types.Target_Size;
      use type MAT.Types.Target_Tick_Ref;
      use type MAT.Types.Target_Thread_Ref;
      use type MAT.Events.Event_Id_Type;
      use type MAT.Events.Probe_Index_Type;
   begin
      case Node.Kind is
         when N_NOT =>
            return not Is_Selected (Node.Expr.all, Event);

         when N_AND =>
            return Is_Selected (Node.Left.all, Event)
              and then Is_Selected (Node.Right.all, Event);

         when N_OR =>
            return Is_Selected (Node.Left.all, Event)
              or else Is_Selected (Node.Right.all, Event);

         when N_RANGE_SIZE =>
            return Event.Size >= Node.Min_Size
              and Event.Size <= Node.Max_Size;

         when N_RANGE_ADDR =>
            return Event.Addr >= Node.Min_Addr
              and Event.Addr <= Node.Max_Addr;

         when N_RANGE_TIME =>
            return Event.Time >= Node.Min_Time
              and Event.Time <= Node.Max_Time;

         when N_EVENT =>
            return Event.Id >= Node.Min_Event
              and Event.Id <= Node.Max_Event;

         when N_THREAD =>
            return Event.Thread >= Node.Min_Thread
              and Event.Thread <= Node.Max_Thread;

         when N_TYPE =>
            return Event.Index = Node.Event_Kind;

         when N_HAS_ADDR =>
            if Event.Index = MAT.Events.MSG_MALLOC
              or Event.Index = MAT.Events.MSG_REALLOC
            then
               return Event.Addr <= Node.Min_Addr and Event.Addr + Event.Size >= Node.Max_Addr;
            end if;
            return False;

         when N_NO_FREE =>
            if Event.Index = MAT.Events.MSG_MALLOC
              or Event.Index = MAT.Events.MSG_REALLOC
            then
               return Event.Next_Id = 0;
            else
               return False;
            end if;

         when N_IN_FUNC =>
            return MAT.Frames.In_Function (Event.Frame, Node.Min_Addr, Node.Max_Addr);

         when N_IN_FUNC_DIRECT =>
            return MAT.Frames.By_Function (Event.Frame, Node.Min_Addr, Node.Max_Addr);

         when others =>
            return False;

      end case;
   end Is_Selected;

   --  ------------------------------
   --  Parse the string and return the expression tree.
   --  ------------------------------
   function Parse (Expr     : in String;
                   Resolver : in Resolver_Type_Access) return Expression_Type is
   begin
      MAT.Expressions.Resolver := Resolver;
      return MAT.Expressions.Parser.Parse (Expr);
   end Parse;

   --  ------------------------------
   --  Destroy recursively the node, releasing the storage.
   --  ------------------------------
   procedure Destroy (Node : in out Node_Type_Access) is
      Release : Boolean;
   begin
      if Node /= null then
         Util.Concurrent.Counters.Decrement (Node.Ref_Counter, Release);
         if Release then
            case Node.Kind is
            when N_NOT =>
               Destroy (Node.Expr);

            when N_AND | N_OR =>
               Destroy (Node.Left);
               Destroy (Node.Right);

            when others =>
               null;
            end case;
            Free (Node);
         else
            Node := null;
         end if;
      end if;
   end Destroy;

   --  ------------------------------
   --  Release the reference and destroy the expression tree if it was the last reference.
   --  ------------------------------
   overriding
   procedure Finalize (Obj : in out Expression_Type) is
   begin
      if Obj.Node /= null then
         Destroy (Obj.Node);
      end if;
   end Finalize;

   --  ------------------------------
   --  Update the reference after an assignment.
   --  ------------------------------
   overriding
   procedure Adjust (Obj : in out Expression_Type) is
   begin
      if Obj.Node /= null then
         Util.Concurrent.Counters.Increment (Obj.Node.Ref_Counter);
      end if;
   end Adjust;

end MAT.Expressions;

Fix the Is_Selected function on a memory slot to support the N_IN_FUNC and N_IN_FUNC_DIRECT selections


-----------------------------------------------------------------------
--  wiki-strings -- Wiki string types and operations
--  Copyright (C) 2016, 2017, 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.Containers;
with Ada.Strings.Wide_Wide_Unbounded;
with Ada.Strings.Wide_Wide_Maps;
with Ada.Strings.Wide_Wide_Hash;
with Ada.Characters.Conversions;
with Ada.Wide_Wide_Characters.Handling;
with Ada.Strings.Wide_Wide_Fixed;
with Ada.Strings.UTF_Encoding.Wide_Wide_Strings;
with Util.Texts.Builders;

package Wiki.Strings is

   pragma Preelaborate;

   subtype WChar is Wide_Wide_Character;
   subtype WString is Wide_Wide_String;
   subtype UString is Ada.Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String;
   subtype WChar_Mapping is Ada.Strings.Wide_Wide_Maps.Wide_Wide_Character_Mapping;

   function To_WChar (C : in Character) return WChar
                      renames Ada.Characters.Conversions.To_Wide_Wide_Character;

   function To_Char (C : in WChar; Substitute : in Character := ' ') return Character
                     renames Ada.Characters.Conversions.To_Character;

   function To_String (S : in WString; Output_BOM : in Boolean := False) return String
                       renames Ada.Strings.UTF_Encoding.Wide_Wide_Strings.Encode;

   function To_UString (S : in WString) return UString
                        renames Ada.Strings.Wide_Wide_Unbounded.To_Unbounded_Wide_Wide_String;

   function To_WString (S : in UString) return WString
                        renames Ada.Strings.Wide_Wide_Unbounded.To_Wide_Wide_String;

   function To_WString (S : in String) return WString
                        renames Ada.Strings.UTF_Encoding.Wide_Wide_Strings.Decode;

   function Hash (S : in WString) return Ada.Containers.Hash_Type
     renames Ada.Strings.Wide_Wide_Hash;

   procedure Append (Into : in out UString; S : in WString)
                     renames Ada.Strings.Wide_Wide_Unbounded.Append;

   procedure Append (Into : in out UString; S : in WChar)
                     renames Ada.Strings.Wide_Wide_Unbounded.Append;

   function Length (S : in UString) return Natural
                    renames Ada.Strings.Wide_Wide_Unbounded.Length;

   function Element (S : in UString; Pos : in Positive) return WChar
                     renames Ada.Strings.Wide_Wide_Unbounded.Element;

   function Is_Alphanumeric (C : in WChar) return Boolean
     renames Ada.Wide_Wide_Characters.Handling.Is_Alphanumeric;

   function Index (S       : in WString;
                   P       : in WString;
                   Going   : in Ada.Strings.Direction := Ada.Strings.Forward;
                   Mapping : in WChar_Mapping := Ada.Strings.Wide_Wide_Maps.Identity)
     return Natural renames Ada.Strings.Wide_Wide_Fixed.Index;

   Null_UString : UString
   renames Ada.Strings.Wide_Wide_Unbounded.Null_Unbounded_Wide_Wide_String;

   package Wide_Wide_Builders is new Util.Texts.Builders (Element_Type => WChar,
                                                          Input        => WString,
                                                          Chunk_Size   => 512);

   subtype BString is Wide_Wide_Builders.Builder;

end Wiki.Strings;

-----------------------------------------------------------------------
--  wiki-strings -- Wiki string types and operations
--  Copyright (C) 2016, 2017, 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.Containers;
with Ada.Strings.Wide_Wide_Unbounded;
with Ada.Strings.Wide_Wide_Maps;
with Ada.Strings.Wide_Wide_Hash;
with Ada.Characters.Conversions;
with Ada.Wide_Wide_Characters.Handling;
with Ada.Strings.Wide_Wide_Fixed;
with Ada.Strings.UTF_Encoding.Wide_Wide_Strings;
with Util.Texts.Builders;

package Wiki.Strings is

   pragma Preelaborate;

   subtype WChar is Wide_Wide_Character;
   subtype WString is Wide_Wide_String;
   subtype UString is Ada.Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String;
   subtype WChar_Mapping is Ada.Strings.Wide_Wide_Maps.Wide_Wide_Character_Mapping;

   function To_WChar (C : in Character) return WChar
                      renames Ada.Characters.Conversions.To_Wide_Wide_Character;

   function To_Char (C : in WChar; Substitute : in Character := ' ') return Character
                     renames Ada.Characters.Conversions.To_Character;

   function To_String (S : in WString; Output_BOM : in Boolean := False) return String
                       renames Ada.Strings.UTF_Encoding.Wide_Wide_Strings.Encode;

   function To_UString (S : in WString) return UString
                        renames Ada.Strings.Wide_Wide_Unbounded.To_Unbounded_Wide_Wide_String;

   function To_WString (S : in UString) return WString
                        renames Ada.Strings.Wide_Wide_Unbounded.To_Wide_Wide_String;

   function To_WString (S : in String) return WString
                        renames Ada.Strings.UTF_Encoding.Wide_Wide_Strings.Decode;

   function Hash (S : in WString) return Ada.Containers.Hash_Type
     renames Ada.Strings.Wide_Wide_Hash;

   procedure Append (Into : in out UString; S : in WString)
                     renames Ada.Strings.Wide_Wide_Unbounded.Append;

   procedure Append (Into : in out UString; S : in WChar)
                     renames Ada.Strings.Wide_Wide_Unbounded.Append;

   function Length (S : in UString) return Natural
                    renames Ada.Strings.Wide_Wide_Unbounded.Length;

   function Element (S : in UString; Pos : in Positive) return WChar
                     renames Ada.Strings.Wide_Wide_Unbounded.Element;

   function Is_Alphanumeric (C : in WChar) return Boolean
     renames Ada.Wide_Wide_Characters.Handling.Is_Alphanumeric;

   function Index (S       : in WString;
                   P       : in WString;
                   Going   : in Ada.Strings.Direction := Ada.Strings.Forward;
                   Mapping : in WChar_Mapping := Ada.Strings.Wide_Wide_Maps.Identity)
     return Natural renames Ada.Strings.Wide_Wide_Fixed.Index;

   Null_UString : UString
   renames Ada.Strings.Wide_Wide_Unbounded.Null_Unbounded_Wide_Wide_String;

   package Wide_Wide_Builders is new Util.Texts.Builders (Element_Type => WChar,
                                                          Input        => WString,
                                                          Chunk_Size   => 512);

   subtype BString is Wide_Wide_Builders.Builder;

   function Element (Source   : in BString;
                     Position : in Positive) return WChar renames Wide_Wide_Builders.Element;

   --  Search for the first occurrence of the character in the builder and
   --  starting after the from index.  Returns the index of the first occurence or 0.
   function Index (Source : in BString;
                   Char   : in WChar;
                   From   : in Positive := 1) return Natural;

end Wiki.Strings;

Add the Element and Index operations

Add the Element and Index operations


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

with ASF.Contexts.Facelets;
with ASF.Applications.Main;
with ASF.Components.Base;
with ASF.Components.Core;
with ASF.Responses;
package body ASF.Applications.Views is

   use ASF.Components;

   type Facelet_Context is new ASF.Contexts.Facelets.Facelet_Context with record
      Facelets    : access ASF.Views.Facelets.Facelet_Factory;
      Application : access ASF.Applications.Main.Application'Class;
   end record;

   --  Include the definition having the given name.
--     overriding
--     procedure Include_Definition (Context : in out Facelet_Context;
--                                   Name    : in Ada.Strings.Unbounded.Unbounded_String;
--                                   Parent  : in UIComponent_Access);

   --  Include the definition having the given name.
   overriding
   procedure Include_Facelet (Context : in out Facelet_Context;
                              Source  : in String;
                              Parent  : in Base.UIComponent_Access);

   --  Get the application associated with this facelet context.
   overriding
   function Get_Application (Context : in Facelet_Context)
                             return access ASF.Applications.Main.Application'Class;

   --  ------------------------------
   --  Include the definition having the given name.
   --  ------------------------------
--     overriding
--     procedure Include_Definition (Context : in out Facelet_Context;
--                                   Name    : in Ada.Strings.Unbounded.Unbounded_String;
--                                   Parent  : in UIComponent_Access) is
--
--        use ASF.Views;
--
--        Tree : Facelets.Facelet;
--     begin
--        Facelets.Find_Facelet (Factory => Context.Facelets.all,
--                               Name    => Ada.Strings.Unbounded.To_String (Name),
--                               Result  => Tree);
--
--        Facelets.Build_View (View    => Tree,
--                             Context => Context,
--                             Root    => Parent);
--     end Include_Definition;

   --  ------------------------------
   --  Include the definition having the given name.
   --  ------------------------------
   overriding
   procedure Include_Facelet (Context : in out Facelet_Context;
                              Source  : in String;
                              Parent  : in Base.UIComponent_Access) is

      use ASF.Views;

      Path : constant String := Context.Resolve_Path (Source);
      Tree : Facelets.Facelet;
   begin
      Facelets.Find_Facelet (Factory => Context.Facelets.all,
                             Name    => Path,
                             Context => Context,
                             Result  => Tree);

      Facelets.Build_View (View    => Tree,
                           Context => Context,
                           Root    => Parent);
   end Include_Facelet;

   --  ------------------------------
   --  Get the application associated with this facelet context.
   --  ------------------------------
   overriding
   function Get_Application (Context : in Facelet_Context)
                             return access ASF.Applications.Main.Application'Class is
   begin
      return Context.Application;
   end Get_Application;

   --  ------------------------------
   --  Get the facelet name from the view name.
   --  ------------------------------
   function Get_Facelet_Name (Handler : in View_Handler;
                              Name    : in String) return String is
      use Ada.Strings.Fixed;
      use Ada.Strings.Unbounded;

      Pos : constant Natural := Index (Name, ".", Ada.Strings.Backward);
   begin
      if Pos > 0 and then To_String (Handler.View_Ext) = Name (Pos .. Name'Last) then
         return Name (Name'First .. Pos - 1) & To_String (Handler.File_Ext);
      end if;
      return Name & To_String (Handler.File_Ext);
   end Get_Facelet_Name;

   --  ------------------------------
   --  Restore the view identified by the given name in the faces context
   --  and create the component tree representing that view.
   --  ------------------------------
   procedure Restore_View (Handler : in out View_Handler;
                           Name    : in String;
                           Context : in out ASF.Contexts.Faces.Faces_Context'Class;
                           View    : out ASF.Components.Root.UIViewRoot) is

      use ASF.Views;

      Ctx       : Facelet_Context;
      Tree      : Facelets.Facelet;
      View_Name : constant String := Handler.Get_Facelet_Name (Name);
   begin
      Ctx.Facelets    := Handler.Facelets'Unchecked_Access;
      Ctx.Application := Context.Get_Application;
      Ctx.Set_ELContext (Context.Get_ELContext);
      Facelets.Find_Facelet (Factory => Handler.Facelets,
                             Name    => View_Name,
                             Context => Ctx,
                             Result  => Tree);
      if Facelets.Is_Null (Tree) then
         Context.Get_Response.Send_Error (ASF.Responses.SC_NOT_FOUND);
         Context.Response_Completed;
         return;
      end if;

      --  Build the component tree for this request.
      declare
         Root : aliased Core.UIComponentBase;
         Node : Base.UIComponent_Access;
      begin
         Facelets.Build_View (View    => Tree,
                              Context => Ctx,
                              Root    => Root'Unchecked_Access);
         ASF.Components.Base.Steal_Root_Component (Root, Node);
         ASF.Components.Root.Set_Root (View, Node, View_Name);
      end;
   end Restore_View;

   --  ------------------------------
   --  Create a new UIViewRoot instance initialized from the context and with
   --  the view identifier.  If the view is a valid view, create the component tree
   --  representing that view.
   --  ------------------------------
   procedure Create_View (Handler : in out View_Handler;
                          Name    : in String;
                          Context : in out ASF.Contexts.Faces.Faces_Context'Class;
                          View    : out ASF.Components.Root.UIViewRoot) is
      Pos : constant Natural := Util.Strings.Rindex (Name, '.');
   begin
      if Pos > 0 then
         Handler.Restore_View (Name (Name'First .. Pos - 1), Context, View);
      else
         Handler.Restore_View (Name, Context, View);
      end if;
   end Create_View;

   --  ------------------------------
   --  Render the view represented by the component tree.  The view is
   --  rendered using the context.
   --  ------------------------------
   procedure Render_View (Handler : in out View_Handler;
                          Context : in out ASF.Contexts.Faces.Faces_Context'Class;
                          View    : in ASF.Components.Root.UIViewRoot) is
      pragma Unreferenced (Handler);

      Root : constant access ASF.Components.Base.UIComponent'Class
        := ASF.Components.Root.Get_Root (View);
   begin
      if Root /= null then
         Root.Encode_All (Context);
      end if;
   end Render_View;

   --  ------------------------------
   --  Initialize the view handler.
   --  ------------------------------
   procedure Initialize (Handler    : out View_Handler;
                         Components : access ASF.Factory.Component_Factory;
                         Conf       : in Config) is
      use ASF.Views;
      use Ada.Strings.Unbounded;
   begin
      Handler.Paths    := To_Unbounded_String (Conf.Get (VIEW_DIR_PARAM));
      Handler.View_Ext := To_Unbounded_String (Conf.Get (VIEW_EXT_PARAM));
      Handler.File_Ext := To_Unbounded_String (Conf.Get (VIEW_FILE_EXT_PARAM));

      Facelets.Initialize (Factory => Handler.Facelets,
                           Components => Components,
                           Paths   => To_String (Handler.Paths),
                           Ignore_White_Spaces => Conf.Get (VIEW_IGNORE_WHITE_SPACES_PARAM),
                           Ignore_Empty_Lines  => Conf.Get (VIEW_IGNORE_EMPTY_LINES_PARAM),
                           Escape_Unknown_Tags => Conf.Get (VIEW_ESCAPE_UNKNOWN_TAGS_PARAM));

   end Initialize;

   --  ------------------------------
   --  Closes the view handler
   --  ------------------------------
   procedure Close (Handler : in out View_Handler) is
      use ASF.Views;
   begin
      Facelets.Clear_Cache (Handler.Facelets);
   end Close;

   --  ------------------------------
   --  Set the extension mapping rule to find the facelet file from
   --  the name.
   --  ------------------------------
   procedure Set_Extension_Mapping (Handler : in out View_Handler;
                                    From    : in String;
                                    Into    : in String) is
      use Ada.Strings.Unbounded;
   begin
      Handler.View_Ext := To_Unbounded_String (From);
      Handler.File_Ext := To_Unbounded_String (Into);
   end Set_Extension_Mapping;

   --  ------------------------------
   --  Register a module
   --  ------------------------------
   procedure Register_Module (Handler : in out View_Handler;
                              Module  : in ASF.Modules.Module_Access) is
      use Ada.Strings.Unbounded;

      Name : constant String := Module.Get_Name;
      URI  : constant String := Module.Get_URI;
      Def  : constant String := To_String (Handler.Paths) & "/" & URI;
      Dir  : constant String := Module.Get_Config (Name & ".web.dir", Def);
   begin
      ASF.Views.Facelets.Register_Module (Handler.Facelets, URI, Dir);
   end Register_Module;

end ASF.Applications.Views;

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

with Util.Files;
with ASF.Contexts.Facelets;
with ASF.Applications.Main;
with ASF.Components.Base;
with ASF.Components.Core;
with ASF.Responses;
package body ASF.Applications.Views is

   use ASF.Components;

   type Facelet_Context is new ASF.Contexts.Facelets.Facelet_Context with record
      Facelets    : access ASF.Views.Facelets.Facelet_Factory;
      Application : access ASF.Applications.Main.Application'Class;
   end record;

   --  Include the definition having the given name.
--     overriding
--     procedure Include_Definition (Context : in out Facelet_Context;
--                                   Name    : in Ada.Strings.Unbounded.Unbounded_String;
--                                   Parent  : in UIComponent_Access);

   --  Include the definition having the given name.
   overriding
   procedure Include_Facelet (Context : in out Facelet_Context;
                              Source  : in String;
                              Parent  : in Base.UIComponent_Access);

   --  Get the application associated with this facelet context.
   overriding
   function Get_Application (Context : in Facelet_Context)
                             return access ASF.Applications.Main.Application'Class;

   --  ------------------------------
   --  Include the definition having the given name.
   --  ------------------------------
--     overriding
--     procedure Include_Definition (Context : in out Facelet_Context;
--                                   Name    : in Ada.Strings.Unbounded.Unbounded_String;
--                                   Parent  : in UIComponent_Access) is
--
--        use ASF.Views;
--
--        Tree : Facelets.Facelet;
--     begin
--        Facelets.Find_Facelet (Factory => Context.Facelets.all,
--                               Name    => Ada.Strings.Unbounded.To_String (Name),
--                               Result  => Tree);
--
--        Facelets.Build_View (View    => Tree,
--                             Context => Context,
--                             Root    => Parent);
--     end Include_Definition;

   --  ------------------------------
   --  Include the definition having the given name.
   --  ------------------------------
   overriding
   procedure Include_Facelet (Context : in out Facelet_Context;
                              Source  : in String;
                              Parent  : in Base.UIComponent_Access) is

      use ASF.Views;

      Path : constant String := Context.Resolve_Path (Source);
      Tree : Facelets.Facelet;
   begin
      Facelets.Find_Facelet (Factory => Context.Facelets.all,
                             Name    => Path,
                             Context => Context,
                             Result  => Tree);

      Facelets.Build_View (View    => Tree,
                           Context => Context,
                           Root    => Parent);
   end Include_Facelet;

   --  ------------------------------
   --  Get the application associated with this facelet context.
   --  ------------------------------
   overriding
   function Get_Application (Context : in Facelet_Context)
                             return access ASF.Applications.Main.Application'Class is
   begin
      return Context.Application;
   end Get_Application;

   --  ------------------------------
   --  Get the facelet name from the view name.
   --  ------------------------------
   function Get_Facelet_Name (Handler : in View_Handler;
                              Name    : in String) return String is
      use Ada.Strings.Fixed;
      use Ada.Strings.Unbounded;

      Pos : constant Natural := Index (Name, ".", Ada.Strings.Backward);
   begin
      if Pos > 0 and then To_String (Handler.View_Ext) = Name (Pos .. Name'Last) then
         return Name (Name'First .. Pos - 1) & To_String (Handler.File_Ext);
      end if;
      return Name & To_String (Handler.File_Ext);
   end Get_Facelet_Name;

   --  ------------------------------
   --  Restore the view identified by the given name in the faces context
   --  and create the component tree representing that view.
   --  ------------------------------
   procedure Restore_View (Handler : in out View_Handler;
                           Name    : in String;
                           Context : in out ASF.Contexts.Faces.Faces_Context'Class;
                           View    : out ASF.Components.Root.UIViewRoot) is

      use ASF.Views;

      Ctx       : Facelet_Context;
      Tree      : Facelets.Facelet;
      View_Name : constant String := Handler.Get_Facelet_Name (Name);
   begin
      Ctx.Facelets    := Handler.Facelets'Unchecked_Access;
      Ctx.Application := Context.Get_Application;
      Ctx.Set_ELContext (Context.Get_ELContext);
      Facelets.Find_Facelet (Factory => Handler.Facelets,
                             Name    => View_Name,
                             Context => Ctx,
                             Result  => Tree);
      if Facelets.Is_Null (Tree) then
         Context.Get_Response.Send_Error (ASF.Responses.SC_NOT_FOUND);
         Context.Response_Completed;
         return;
      end if;

      --  Build the component tree for this request.
      declare
         Root : aliased Core.UIComponentBase;
         Node : Base.UIComponent_Access;
      begin
         Facelets.Build_View (View    => Tree,
                              Context => Ctx,
                              Root    => Root'Unchecked_Access);
         ASF.Components.Base.Steal_Root_Component (Root, Node);
         ASF.Components.Root.Set_Root (View, Node, View_Name);
      end;
   end Restore_View;

   --  ------------------------------
   --  Create a new UIViewRoot instance initialized from the context and with
   --  the view identifier.  If the view is a valid view, create the component tree
   --  representing that view.
   --  ------------------------------
   procedure Create_View (Handler : in out View_Handler;
                          Name    : in String;
                          Context : in out ASF.Contexts.Faces.Faces_Context'Class;
                          View    : out ASF.Components.Root.UIViewRoot) is
      Pos : constant Natural := Util.Strings.Rindex (Name, '.');
   begin
      if Pos > 0 then
         Handler.Restore_View (Name (Name'First .. Pos - 1), Context, View);
      else
         Handler.Restore_View (Name, Context, View);
      end if;
   end Create_View;

   --  ------------------------------
   --  Render the view represented by the component tree.  The view is
   --  rendered using the context.
   --  ------------------------------
   procedure Render_View (Handler : in out View_Handler;
                          Context : in out ASF.Contexts.Faces.Faces_Context'Class;
                          View    : in ASF.Components.Root.UIViewRoot) is
      pragma Unreferenced (Handler);

      Root : constant access ASF.Components.Base.UIComponent'Class
        := ASF.Components.Root.Get_Root (View);
   begin
      if Root /= null then
         Root.Encode_All (Context);
      end if;
   end Render_View;

   --  ------------------------------
   --  Initialize the view handler.
   --  ------------------------------
   procedure Initialize (Handler    : out View_Handler;
                         Components : access ASF.Factory.Component_Factory;
                         Conf       : in Config) is
      use ASF.Views;
      use Ada.Strings.Unbounded;
   begin
      Handler.Paths    := To_Unbounded_String (Conf.Get (VIEW_DIR_PARAM));
      Handler.View_Ext := To_Unbounded_String (Conf.Get (VIEW_EXT_PARAM));
      Handler.File_Ext := To_Unbounded_String (Conf.Get (VIEW_FILE_EXT_PARAM));

      Facelets.Initialize (Factory => Handler.Facelets,
                           Components => Components,
                           Paths   => To_String (Handler.Paths),
                           Ignore_White_Spaces => Conf.Get (VIEW_IGNORE_WHITE_SPACES_PARAM),
                           Ignore_Empty_Lines  => Conf.Get (VIEW_IGNORE_EMPTY_LINES_PARAM),
                           Escape_Unknown_Tags => Conf.Get (VIEW_ESCAPE_UNKNOWN_TAGS_PARAM));

   end Initialize;

   --  ------------------------------
   --  Closes the view handler
   --  ------------------------------
   procedure Close (Handler : in out View_Handler) is
      use ASF.Views;
   begin
      Facelets.Clear_Cache (Handler.Facelets);
   end Close;

   --  ------------------------------
   --  Set the extension mapping rule to find the facelet file from
   --  the name.
   --  ------------------------------
   procedure Set_Extension_Mapping (Handler : in out View_Handler;
                                    From    : in String;
                                    Into    : in String) is
      use Ada.Strings.Unbounded;
   begin
      Handler.View_Ext := To_Unbounded_String (From);
      Handler.File_Ext := To_Unbounded_String (Into);
   end Set_Extension_Mapping;

   --  ------------------------------
   --  Register a module
   --  ------------------------------
   procedure Register_Module (Handler : in out View_Handler;
                              Module  : in ASF.Modules.Module_Access) is
      use Ada.Strings.Unbounded;

      Name : constant String := Module.Get_Name;
      URI  : constant String := Module.Get_URI;
      Def  : constant String := Util.Files.Compose_Path (To_String (Handler.Paths), URI);
      Dir  : constant String := Module.Get_Config (Name & ".web.dir", Def);
   begin
      ASF.Views.Facelets.Register_Module (Handler.Facelets, URI, Dir);
   end Register_Module;

end ASF.Applications.Views;

Use Compose_Path to create the module specific search path


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

package body ASF.Navigations.Render is

   use Ada.Exceptions;
   use Util.Log;
   use ASF.Applications;

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

   --  ------------------------------
   --  Navigate to the next page or action according to the controller's navigator.
   --  A navigator controller could redirect the user to another page, render a specific
   --  view or return some raw content.
   --  ------------------------------
   overriding
   procedure Navigate (Controller : in Render_Navigator;
                       Context    : in out ASF.Contexts.Faces.Faces_Context'Class) is
      Name : constant String := To_String (Controller.View_Name);
      View : Components.Root.UIViewRoot;
   begin
      Log.Debug ("Navigate to view {0}", Name);

      Controller.View_Handler.Create_View (Name, Context, View);

      Context.Set_View_Root (View);

   exception
      when E : others =>
         Log.Error ("Error when navigating to view {0}: {1}: {2}", Name,
                    Exception_Name (E), Exception_Message (E));
         raise;

   end Navigate;

   --  ------------------------------
   --  Create a navigation case to render a view.
   --  ------------------------------
   function Create_Render_Navigator (To_View : in String) return Navigation_Access is
      Result : constant Render_Navigator_Access := new Render_Navigator;
   begin
      Result.View_Name := To_Unbounded_String (To_View);
      return Result.all'Access;
   end Create_Render_Navigator;

end ASF.Navigations.Render;

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

package body ASF.Navigations.Render is

   use Ada.Exceptions;
   use ASF.Applications;

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

   --  ------------------------------
   --  Navigate to the next page or action according to the controller's navigator.
   --  A navigator controller could redirect the user to another page, render a specific
   --  view or return some raw content.
   --  ------------------------------
   overriding
   procedure Navigate (Controller : in Render_Navigator;
                       Context    : in out ASF.Contexts.Faces.Faces_Context'Class) is
      View : Components.Root.UIViewRoot;
   begin
      Log.Debug ("Navigate to view {0}", Controller.View_Name);

      if Controller.Status /= 0 then
         Context.Get_Response.Set_Status (Controller.Status);
      end if;
      Controller.View_Handler.Create_View (Controller.View_Name, Context, View);

      Context.Set_View_Root (View);

   exception
      when E : others =>
         Log.Error ("Error when navigating to view {0}: {1}: {2}", Controller.View_Name,
                    Exception_Name (E), Exception_Message (E));
         raise;

   end Navigate;

   --  ------------------------------
   --  Create a navigation case to render a view.
   --  ------------------------------
   function Create_Render_Navigator (To_View : in String;
                                     Status  : in Natural) return Navigation_Access is
      Result : constant Render_Navigator_Access
        := new Render_Navigator '(Len       => To_View'Length,
                                  Status    => Status,
                                  View_Name => To_View,
                                  others    => <>);
   begin
      return Result.all'Access;
   end Create_Render_Navigator;

end ASF.Navigations.Render;

Change the Create_Render_Navigator to store the status parameter and the view name as a string Update Navigate operation to change the response status if it was set


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

with Util.Tests;

package Security.Permissions.Tests is

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

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

   --  Test Add_Permission and Get_Permission_Index
   procedure Test_Add_Permission (T : in out Test);

   --  Test Create_Role and Get_Role_Name
   procedure Test_Create_Role (T : in out Test);

   --  Test Has_Permission
   procedure Test_Has_Permission (T : in out Test);

   --  Test reading policy files
   procedure Test_Read_Policy (T : in out Test);

   --  Test reading policy files and using the <role-permission> controller
   procedure Test_Role_Policy (T : in out Test);

      --  Read the policy file <b>File</b> and perform a test on the given URI
   --  with a user having the given role.
   procedure Check_Policy (T     : in out Test;
                           File  : in String;
                           Role  : in String;
                           URI   : in String);

   type Test_Principal is new Principal with record
      Name  : Util.Strings.String_Ref;
      Roles : Role_Map := (others => False);
   end record;

   --  Returns true if the given permission is stored in the user principal.
   function Has_Role (User : in Test_Principal;
                      Role : in Role_Type) return Boolean;

   --  Get the principal name.
   function Get_Name (From : in Test_Principal) return String;

end Security.Permissions.Tests;

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

with Util.Tests;

package Security.Permissions.Tests is

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

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

   --  Test Add_Permission and Get_Permission_Index
   procedure Test_Add_Permission (T : in out Test);

end Security.Permissions.Tests;

Remove the policy specific unit tests

Remove the policy specific unit tests