-----------------------------------------------------------------------
--  mat-events-timelines - Timelines
--  Copyright (C) 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.
-----------------------------------------------------------------------

package body MAT.Events.Timelines is

   use MAT.Events.Targets;

   ITERATE_COUNT : constant MAT.Events.Targets.Event_Id_Type := 10_000;

   procedure Extract (Target : in out MAT.Events.Targets.Target_Events;
                      Into   : in out Timeline_Info_Vector) is
      use type MAT.Types.Target_Time;
      procedure Collect (Event : in MAT.Events.Targets.Probe_Event_Type);

      First_Event : MAT.Events.Targets.Probe_Event_Type;
      Last_Event  : MAT.Events.Targets.Probe_Event_Type;
      Prev_Event  : MAT.Events.Targets.Probe_Event_Type;
      Info        : Timeline_Info;
      First_Id    : MAT.Events.Targets.Event_Id_Type;

      procedure Collect (Event : in MAT.Events.Targets.Probe_Event_Type) is
         Dt : constant MAT.Types.Target_Time := Event.Time - Prev_Event.Time;
      begin
         if Dt > 500_000 then
            Into.Append (Info);
            Info.Malloc_Count := 0;
            Info.Realloc_Count := 0;
            Info.Free_Count := 0;
            Info.Start_Id := Event.Id;
            Info.Start_Time := Event.Time;
         end if;
         Info.End_Id := Event.Id;
         Info.End_Time := Event.Time;
         if Event.Event = 2 then
            Info.Malloc_Count := Info.Malloc_Count + 1;
         elsif Event.Event = 3 then
            Info.Realloc_Count := Info.Realloc_Count + 1;
         elsif Event.Event = 4 then
            Info.Free_Count := Info.Free_Count + 1;
         end if;
      end Collect;

   begin
      Target.Get_Limits (First_Event, Last_Event);
      Prev_Event      := First_Event;
      Info.Start_Id   := First_Event.Id;
      Info.Start_Time := First_Event.Time;
      First_Id := First_Event.Id;
      while First_Id < Last_Event.Id loop
         Target.Iterate (Start   => First_Id,
                         Finish  => First_Id + ITERATE_COUNT,
                         Process => Collect'Access);
         First_Id := First_Id + ITERATE_COUNT;
      end loop;
   end Extract;

   --  ------------------------------
   --  Find in the events stream the events which are associated with a given event.
   --  When the <tt>Event</tt> is a memory allocation, find the associated reallocation
   --  and free events.  When the event is a free, find the associated allocations.
   --  Collect at most <tt>Max</tt> events.
   --  ------------------------------
   procedure Find_Related (Target : in out MAT.Events.Targets.Target_Events'Class;
                           Event  : in MAT.Events.Targets.Probe_Event_Type;
                           Max    : in Positive;
                           List   : in out MAT.Events.Targets.Target_Event_Vector) is

      procedure Collect_Free (Event : in MAT.Events.Targets.Probe_Event_Type);
      procedure Collect_Alloc (Event : in MAT.Events.Targets.Probe_Event_Type);

      First_Id    : MAT.Events.Targets.Event_Id_Type;
      Last_Id     : MAT.Events.Targets.Event_Id_Type;
      First_Event : MAT.Events.Targets.Probe_Event_Type;
      Last_Event  : MAT.Events.Targets.Probe_Event_Type;
      Addr        : MAT.Types.Target_Addr := Event.Addr;

      Done : exception;

      procedure Collect_Free (Event : in MAT.Events.Targets.Probe_Event_Type) is
      begin
         if Event.Index = MAT.Events.Targets.MSG_FREE and then Event.Addr = Addr then
            List.Append (Event);
            raise Done;
         end if;
         if Event.Index = MAT.Events.Targets.MSG_REALLOC and then Event.Old_Addr = Addr then
            List.Append (Event);
            if Positive (List.Length) >= Max then
               raise Done;
            end if;
            Addr := Event.Addr;
         end if;
      end Collect_Free;

      procedure Collect_Alloc (Event : in MAT.Events.Targets.Probe_Event_Type) is
      begin
         if Event.Index = MAT.Events.Targets.MSG_MALLOC and then Event.Addr = Addr then
            List.Append (Event);
            raise Done;
         end if;
         if Event.Index = MAT.Events.Targets.MSG_REALLOC and then Event.Addr = Addr then
            List.Append (Event);
            if Positive (List.Length) >= Max then
               raise Done;
            end if;
            Addr := Event.Old_Addr;
         end if;
      end Collect_Alloc;

   begin
      Target.Get_Limits (First_Event, Last_Event);
      First_Id := Event.Id;
      if Event.Index = MAT.Events.Targets.MSG_FREE then
         --  Search backward for MSG_MALLOC and MSG_REALLOC.
         First_Id := First_Id - 1;
         while First_Id > First_Event.Id loop
            if First_Id > ITERATE_COUNT then
               Last_Id := First_Id - ITERATE_COUNT;
            else
               Last_Id := First_Event.Id;
            end if;
            Target.Iterate (Start   => First_Id,
                            Finish  => Last_Id,
                            Process => Collect_Alloc'Access);
            First_Id := Last_Id;
         end loop;
      else
         --  Search forward for MSG_REALLOC and MSG_FREE
         First_Id := First_Id + 1;
         while First_Id < Last_Event.Id loop
            Target.Iterate (Start   => First_Id,
                            Finish  => First_Id + ITERATE_COUNT,
                            Process => Collect_Free'Access);
            First_Id := First_Id + ITERATE_COUNT;
         end loop;
      end if;

   exception
      when Done =>
         null;
   end Find_Related;

   --  ------------------------------
   --  Find the sizes of malloc and realloc events which is selected by the given filter.
   --  Update the <tt>Sizes</tt> map to keep track of the first event and last event and
   --  the number of events found for the corresponding size.
   --  ------------------------------
   procedure Find_Sizes (Target : in out MAT.Events.Targets.Target_Events'Class;
                         Filter : in MAT.Expressions.Expression_Type;
                         Sizes  : in out MAT.Events.Targets.Size_Event_Info_Map) is
      procedure Collect_Event (Event : in MAT.Events.Targets.Target_Event);

      procedure Collect_Event (Event : in MAT.Events.Targets.Target_Event) is
         procedure Update_Size (Size : in MAT.Types.Target_Size;
                                Info : in out MAT.Events.Targets.Event_Info_Type);

         procedure Update_Size (Size : in MAT.Types.Target_Size;
                                Info : in out MAT.Events.Targets.Event_Info_Type) is
            pragma Unreferenced (Size);
         begin
            Info.Count      := Info.Count + 1;
            Info.Last_Event := Event;
         end Update_Size;

      begin
         --  Look for malloc or realloc events which are selected by the filter.
         if (Event.Index /= MAT.Events.Targets.MSG_MALLOC
             and Event.Index /= MAT.Events.Targets.MSG_REALLOC)
           or else not Filter.Is_Selected (Event)
         then
            return;
         end if;
         declare
            Pos : constant MAT.Events.Targets.Size_Event_Info_Cursor := Sizes.Find (Event.Size);
         begin
            if MAT.Events.Targets.Size_Event_Info_Maps.Has_Element (Pos) then
               --  Increment the count and update the last event.
               Sizes.Update_Element (Pos, Update_Size'Access);
            else
               declare
                  Info : Event_Info_Type;
               begin
                  --  Insert a new size with the event.
                  Info.First_Event := Event;
                  Info.Last_Event := Event;
                  Info.Count := 1;
                  Sizes.Insert (Event.Size, Info);
               end;
            end if;
         end;
      end Collect_Event;

   begin
      Target.Iterate (Process => Collect_Event'Access);
   end Find_Sizes;

end MAT.Events.Timelines;

-----------------------------------------------------------------------
--  mat-events-timelines - Timelines
--  Copyright (C) 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 MAT.Frames;
package body MAT.Events.Timelines is

   use MAT.Events.Targets;

   ITERATE_COUNT : constant MAT.Events.Targets.Event_Id_Type := 10_000;

   procedure Extract (Target : in out MAT.Events.Targets.Target_Events;
                      Into   : in out Timeline_Info_Vector) is
      use type MAT.Types.Target_Time;
      procedure Collect (Event : in MAT.Events.Targets.Probe_Event_Type);

      First_Event : MAT.Events.Targets.Probe_Event_Type;
      Last_Event  : MAT.Events.Targets.Probe_Event_Type;
      Prev_Event  : MAT.Events.Targets.Probe_Event_Type;
      Info        : Timeline_Info;
      First_Id    : MAT.Events.Targets.Event_Id_Type;

      procedure Collect (Event : in MAT.Events.Targets.Probe_Event_Type) is
         Dt : constant MAT.Types.Target_Time := Event.Time - Prev_Event.Time;
      begin
         if Dt > 500_000 then
            Into.Append (Info);
            Info.Malloc_Count := 0;
            Info.Realloc_Count := 0;
            Info.Free_Count := 0;
            Info.Start_Id := Event.Id;
            Info.Start_Time := Event.Time;
         end if;
         Info.End_Id := Event.Id;
         Info.End_Time := Event.Time;
         if Event.Event = 2 then
            Info.Malloc_Count := Info.Malloc_Count + 1;
         elsif Event.Event = 3 then
            Info.Realloc_Count := Info.Realloc_Count + 1;
         elsif Event.Event = 4 then
            Info.Free_Count := Info.Free_Count + 1;
         end if;
      end Collect;

   begin
      Target.Get_Limits (First_Event, Last_Event);
      Prev_Event      := First_Event;
      Info.Start_Id   := First_Event.Id;
      Info.Start_Time := First_Event.Time;
      First_Id := First_Event.Id;
      while First_Id < Last_Event.Id loop
         Target.Iterate (Start   => First_Id,
                         Finish  => First_Id + ITERATE_COUNT,
                         Process => Collect'Access);
         First_Id := First_Id + ITERATE_COUNT;
      end loop;
   end Extract;

   --  ------------------------------
   --  Find in the events stream the events which are associated with a given event.
   --  When the <tt>Event</tt> is a memory allocation, find the associated reallocation
   --  and free events.  When the event is a free, find the associated allocations.
   --  Collect at most <tt>Max</tt> events.
   --  ------------------------------
   procedure Find_Related (Target : in out MAT.Events.Targets.Target_Events'Class;
                           Event  : in MAT.Events.Targets.Probe_Event_Type;
                           Max    : in Positive;
                           List   : in out MAT.Events.Targets.Target_Event_Vector) is

      procedure Collect_Free (Event : in MAT.Events.Targets.Probe_Event_Type);
      procedure Collect_Alloc (Event : in MAT.Events.Targets.Probe_Event_Type);

      First_Id    : MAT.Events.Targets.Event_Id_Type;
      Last_Id     : MAT.Events.Targets.Event_Id_Type;
      First_Event : MAT.Events.Targets.Probe_Event_Type;
      Last_Event  : MAT.Events.Targets.Probe_Event_Type;
      Addr        : MAT.Types.Target_Addr := Event.Addr;

      Done : exception;

      procedure Collect_Free (Event : in MAT.Events.Targets.Probe_Event_Type) is
      begin
         if Event.Index = MAT.Events.Targets.MSG_FREE and then Event.Addr = Addr then
            List.Append (Event);
            raise Done;
         end if;
         if Event.Index = MAT.Events.Targets.MSG_REALLOC and then Event.Old_Addr = Addr then
            List.Append (Event);
            if Positive (List.Length) >= Max then
               raise Done;
            end if;
            Addr := Event.Addr;
         end if;
      end Collect_Free;

      procedure Collect_Alloc (Event : in MAT.Events.Targets.Probe_Event_Type) is
      begin
         if Event.Index = MAT.Events.Targets.MSG_MALLOC and then Event.Addr = Addr then
            List.Append (Event);
            raise Done;
         end if;
         if Event.Index = MAT.Events.Targets.MSG_REALLOC and then Event.Addr = Addr then
            List.Append (Event);
            if Positive (List.Length) >= Max then
               raise Done;
            end if;
            Addr := Event.Old_Addr;
         end if;
      end Collect_Alloc;

   begin
      Target.Get_Limits (First_Event, Last_Event);
      First_Id := Event.Id;
      if Event.Index = MAT.Events.Targets.MSG_FREE then
         --  Search backward for MSG_MALLOC and MSG_REALLOC.
         First_Id := First_Id - 1;
         while First_Id > First_Event.Id loop
            if First_Id > ITERATE_COUNT then
               Last_Id := First_Id - ITERATE_COUNT;
            else
               Last_Id := First_Event.Id;
            end if;
            Target.Iterate (Start   => First_Id,
                            Finish  => Last_Id,
                            Process => Collect_Alloc'Access);
            First_Id := Last_Id;
         end loop;
      else
         --  Search forward for MSG_REALLOC and MSG_FREE
         First_Id := First_Id + 1;
         while First_Id < Last_Event.Id loop
            Target.Iterate (Start   => First_Id,
                            Finish  => First_Id + ITERATE_COUNT,
                            Process => Collect_Free'Access);
            First_Id := First_Id + ITERATE_COUNT;
         end loop;
      end if;

   exception
      when Done =>
         null;
   end Find_Related;

   --  ------------------------------
   --  Find the sizes of malloc and realloc events which is selected by the given filter.
   --  Update the <tt>Sizes</tt> map to keep track of the first event and last event and
   --  the number of events found for the corresponding size.
   --  ------------------------------
   procedure Find_Sizes (Target : in out MAT.Events.Targets.Target_Events'Class;
                         Filter : in MAT.Expressions.Expression_Type;
                         Sizes  : in out MAT.Events.Targets.Size_Event_Info_Map) is
      procedure Collect_Event (Event : in MAT.Events.Targets.Target_Event);

      procedure Collect_Event (Event : in MAT.Events.Targets.Target_Event) is
         procedure Update_Size (Size : in MAT.Types.Target_Size;
                                Info : in out MAT.Events.Targets.Event_Info_Type);

         procedure Update_Size (Size : in MAT.Types.Target_Size;
                                Info : in out MAT.Events.Targets.Event_Info_Type) is
            pragma Unreferenced (Size);
         begin
            Info.Count      := Info.Count + 1;
            Info.Last_Event := Event;
         end Update_Size;

      begin
         --  Look for malloc or realloc events which are selected by the filter.
         if (Event.Index /= MAT.Events.Targets.MSG_MALLOC
             and Event.Index /= MAT.Events.Targets.MSG_REALLOC)
           or else not Filter.Is_Selected (Event)
         then
            return;
         end if;
         declare
            Pos : constant MAT.Events.Targets.Size_Event_Info_Cursor := Sizes.Find (Event.Size);
         begin
            if MAT.Events.Targets.Size_Event_Info_Maps.Has_Element (Pos) then
               --  Increment the count and update the last event.
               Sizes.Update_Element (Pos, Update_Size'Access);
            else
               declare
                  Info : Event_Info_Type;
               begin
                  --  Insert a new size with the event.
                  Info.First_Event := Event;
                  Info.Last_Event := Event;
                  Info.Count := 1;
                  Sizes.Insert (Event.Size, Info);
               end;
            end if;
         end;
      end Collect_Event;

   begin
      Target.Iterate (Process => Collect_Event'Access);
   end Find_Sizes;

   --  ------------------------------
   --  Find the function address from the call event frames for the events which is selected
   --  by the given filter.  The function addresses are collected up to the given frame depth.
   --  Update the <tt>Frames</tt> map to keep track of the first event and last event and
   --  the number of events found for the corresponding frame address.
   --  ------------------------------
   procedure Find_Frames (Target : in out MAT.Events.Targets.Target_Events'Class;
                          Filter : in MAT.Expressions.Expression_Type;
                          Depth  : in Natural;
                          Frames : in out MAT.Events.Targets.Frame_Event_Info_Map) is
      procedure Collect_Event (Event : in MAT.Events.Targets.Target_Event);

      procedure Collect_Event (Event : in MAT.Events.Targets.Target_Event) is
         procedure Update_Size (Size : in MAT.Types.Target_Size;
                                Info : in out MAT.Events.Targets.Event_Info_Type);

         procedure Update_Size (Size : in MAT.Types.Target_Size;
                                Info : in out MAT.Events.Targets.Event_Info_Type) is
            pragma Unreferenced (Size);
         begin
            Info.Count      := Info.Count + 1;
            Info.Last_Event := Event;
         end Update_Size;

      begin
         --  Look for events which are selected by the filter.
         if not Filter.Is_Selected (Event) then
            return;
         end if;
         declare
            Backtrace : constant MAT.Frames.Frame_Table := MAT.Frames.Backtrace (Event.Frame);
         begin
            for I in Backtrace'Range loop
               exit when I > Depth;
               declare
                  Pos : constant MAT.Events.Targets.Frame_Event_Info_Cursor
                    := Frames.Find (Backtrace (I));
               begin
                  if MAT.Events.Targets.Frame_Event_Info_Maps.Has_Element (Pos) then
                     --  Increment the count and update the last event.
                     Frames.Update_Element (Pos, Update_Size'Access);
                  else
                     declare
                        Info : Event_Info_Type;
                     begin
                        --  Insert a new size with the event.
                        Info.First_Event := Event;
                        Info.Last_Event := Event;
                        Info.Count := 1;
                        Frames.Insert (Backtrace (I), Info);
                     end;
                  end if;
               end;
            end loop;
         end;
      end Collect_Event;

   begin
      Target.Iterate (Process => Collect_Event'Access);
   end Find_Frames;

end MAT.Events.Timelines;

Implement the Find_Frames procedure to collect function addresses that perform directly or indirectly malloc/realloc/free calls


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

with Ada.Containers.Vectors;
with Ada.Strings.Wide_Wide_Unbounded;

with Util.Beans.Basic;
with Util.Beans.Objects;
with Util.Refs;

package ASF.Models.Selects is

   --  ------------------------------
   --  Select Item
   --  ------------------------------
   --  The Select_Item type describes a single option of a list of options
   --  used by the UISelectOne or UISelectMany components.
   --  The select item contains:
   --

   --
A label
   --
A value
   --
A description
   --
Whether the select item is disabled or not
   --
Whether the label is escaped or not
   --

   --  An application creates the Select_Item instances and passes them
   --  to the ASF components through an Util.Beans.Objects.Object value.
   type Select_Item is new Util.Beans.Basic.Readonly_Bean with private;
   type Select_Item_Access is access all Select_Item;

   --  Return an Object from the select item record.
   --  Returns a NULL object if the item is empty.
   function To_Object (Item : in Select_Item) return Util.Beans.Objects.Object;

   --  Return the Select_Item instance from a generic bean object.
   --  Returns an empty item if the object does not hold a Select_Item.
   function To_Select_Item (Object : in Util.Beans.Objects.Object) return Select_Item;

   --  Creates a Select_Item with the specified label and value.
   function Create_Select_Item (Label       : in String;
                                Value       : in String;
                                Description : in String := "";
                                Disabled    : in Boolean := False;
                                Escaped     : in Boolean := True) return Select_Item;

   --  Creates a Select_Item with the specified label and value.
   function Create_Select_Item_Wide (Label       : in Wide_Wide_String;
                                     Value       : in Wide_Wide_String;
                                     Description : in Wide_Wide_String := "";
                                     Disabled    : in Boolean := False;
                                     Escaped     : in Boolean := True) return Select_Item;

   --  Creates a Select_Item with the specified label, value and description.
   --  The objects are converted to a wide wide string.  The empty string is used if they
   --  are null.
   function Create_Select_Item (Label       : in Util.Beans.Objects.Object;
                                Value       : in Util.Beans.Objects.Object;
                                Description : in Util.Beans.Objects.Object;
                                Disabled    : in Boolean := False;
                                Escaped     : in Boolean := True) return Select_Item;

   --  Get the item label.
   function Get_Label (Item : in Select_Item) return Wide_Wide_String;

   --  Get the item value.
   function Get_Value (Item : in Select_Item) return Wide_Wide_String;

   --  Get the item description.
   function Get_Description (Item : in Select_Item) return Wide_Wide_String;

   --  Returns true if the item is disabled.
   function Is_Disabled (Item : in Select_Item) return Boolean;

   --  Returns true if the label must be escaped using HTML escape rules.
   function Is_Escaped (Item : in Select_Item) return Boolean;

   --  Returns true if the select item component is empty.
   function Is_Empty (Item : in Select_Item) return Boolean;

   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   overriding
   function Get_Value (From : in Select_Item;
                       Name : in String) return Util.Beans.Objects.Object;

   --  ------------------------------
   --  Select Item List
   --  ------------------------------
   --  The Select_Item_List type holds a list of Select_Item.
   --  Similar to Select_Item, an application builds the list items and gives it
   --  to the ASF components through an Util.Beans.Objects.Object instance.
   type Select_Item_List is new Util.Beans.Basic.List_Bean with private;
   type Select_Item_List_Access is access all Select_Item_List;

   --  Return an Object from the select item list.
   --  Returns a NULL object if the list is empty.
   function To_Object (Item : in Select_Item_List) return Util.Beans.Objects.Object;

   --  Return the Select_Item_List instance from a generic bean object.
   --  Returns an empty list if the object does not hold a Select_Item_List.
   function To_Select_Item_List (Object : in Util.Beans.Objects.Object) return Select_Item_List;

   --  Get the number of elements in the list.
   overriding
   function Get_Count (From : in Select_Item_List) return Natural;

   --  Set the current row index.  Valid row indexes start at 1.
   overriding
   procedure Set_Row_Index (From  : in out Select_Item_List;
                            Index : in Natural);

   --  Get the element at the current row index.
   overriding
   function Get_Row (From  : in Select_Item_List) return Util.Beans.Objects.Object;

   --  Get the number of items in the list.
   function Length (List : in Select_Item_List) return Natural;

   --  Get the select item from the list
   function Get_Select_Item (List : in Select_Item_List'Class;
                             Pos  : in Positive) return Select_Item;

   --  Add the item at the end of the list.
   procedure Append (List : in out Select_Item_List;
                     Item : in Select_Item'Class);

   --  Add the item at the end of the list.  This is a shortcut for
   --  Append (Create_List_Item (Label, Value))
   procedure Append (List  : in out Select_Item_List;
                     Label : in String;
                     Value : in String);

private

   use Ada.Strings.Wide_Wide_Unbounded;

   type Select_Item_Record is new Util.Refs.Ref_Entity with record
      Label       : Unbounded_Wide_Wide_String;
      Value       : Unbounded_Wide_Wide_String;
      Description : Unbounded_Wide_Wide_String;
      Disabled    : Boolean := False;
      Escape      : Boolean := False;
   end record;
   type Select_Item_Record_Access is access all Select_Item_Record;

   package Select_Item_Refs is
      new Util.Refs.References (Element_Type   => Select_Item_Record,
                                Element_Access => Select_Item_Record_Access);

   type Select_Item is new Util.Beans.Basic.Readonly_Bean with record
      Item : Select_Item_Refs.Ref;
   end record;

   package Select_Item_Vectors is
      new Ada.Containers.Vectors (Index_Type   => Positive,
                                  Element_Type => Select_Item);

   type Select_Item_Vector is new Util.Refs.Ref_Entity with record
      List  : Select_Item_Vectors.Vector;
   end record;
   type Select_Item_Vector_Access is access all Select_Item_Vector;

   package Select_Item_Vector_Refs is
      new Util.Refs.References (Element_Type   => Select_Item_Vector,
                                Element_Access => Select_Item_Vector_Access);

   type Select_Item_List is new Util.Beans.Basic.List_Bean with record
      List    : Select_Item_Vector_Refs.Ref;
      Current : aliased Select_Item;
      Row     : Util.Beans.Objects.Object;
   end record;

   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   overriding
   function Get_Value (From : in Select_Item_List;
                       Name : in String) return Util.Beans.Objects.Object;

end ASF.Models.Selects;

-----------------------------------------------------------------------
--  asf-models-selects -- Data model for UISelectOne and UISelectMany
--  Copyright (C) 2011, 2012, 2013, 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.Containers.Vectors;
with Ada.Strings.Wide_Wide_Unbounded;

with Util.Beans.Basic;
with Util.Beans.Objects;
private with Util.Refs;

package ASF.Models.Selects is

   --  ------------------------------
   --  Select Item
   --  ------------------------------
   --  The Select_Item type describes a single option of a list of options
   --  used by the UISelectOne or UISelectMany components.
   --  The select item contains:
   --

   --
A label
   --
A value
   --
A description
   --
Whether the select item is disabled or not
   --
Whether the label is escaped or not
   --

   --  An application creates the Select_Item instances and passes them
   --  to the ASF components through an Util.Beans.Objects.Object value.
   type Select_Item is new Util.Beans.Basic.Readonly_Bean with private;
   type Select_Item_Access is access all Select_Item;

   --  Return an Object from the select item record.
   --  Returns a NULL object if the item is empty.
   function To_Object (Item : in Select_Item) return Util.Beans.Objects.Object;

   --  Return the Select_Item instance from a generic bean object.
   --  Returns an empty item if the object does not hold a Select_Item.
   function To_Select_Item (Object : in Util.Beans.Objects.Object) return Select_Item;

   --  Creates a Select_Item with the specified label and value.
   function Create_Select_Item (Label       : in String;
                                Value       : in String;
                                Description : in String := "";
                                Disabled    : in Boolean := False;
                                Escaped     : in Boolean := True) return Select_Item;

   --  Creates a Select_Item with the specified label and value.
   function Create_Select_Item_Wide (Label       : in Wide_Wide_String;
                                     Value       : in Wide_Wide_String;
                                     Description : in Wide_Wide_String := "";
                                     Disabled    : in Boolean := False;
                                     Escaped     : in Boolean := True) return Select_Item;

   --  Creates a Select_Item with the specified label, value and description.
   --  The objects are converted to a wide wide string.  The empty string is used if they
   --  are null.
   function Create_Select_Item (Label       : in Util.Beans.Objects.Object;
                                Value       : in Util.Beans.Objects.Object;
                                Description : in Util.Beans.Objects.Object;
                                Disabled    : in Boolean := False;
                                Escaped     : in Boolean := True) return Select_Item;

   --  Get the item label.
   function Get_Label (Item : in Select_Item) return Wide_Wide_String;

   --  Get the item value.
   function Get_Value (Item : in Select_Item) return Wide_Wide_String;

   --  Get the item description.
   function Get_Description (Item : in Select_Item) return Wide_Wide_String;

   --  Returns true if the item is disabled.
   function Is_Disabled (Item : in Select_Item) return Boolean;

   --  Returns true if the label must be escaped using HTML escape rules.
   function Is_Escaped (Item : in Select_Item) return Boolean;

   --  Returns true if the select item component is empty.
   function Is_Empty (Item : in Select_Item) return Boolean;

   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   overriding
   function Get_Value (From : in Select_Item;
                       Name : in String) return Util.Beans.Objects.Object;

   --  ------------------------------
   --  Select Item List
   --  ------------------------------
   --  The Select_Item_List type holds a list of Select_Item.
   --  Similar to Select_Item, an application builds the list items and gives it
   --  to the ASF components through an Util.Beans.Objects.Object instance.
   type Select_Item_List is new Util.Beans.Basic.List_Bean with private;
   type Select_Item_List_Access is access all Select_Item_List;

   --  Return an Object from the select item list.
   --  Returns a NULL object if the list is empty.
   function To_Object (Item : in Select_Item_List) return Util.Beans.Objects.Object;

   --  Return the Select_Item_List instance from a generic bean object.
   --  Returns an empty list if the object does not hold a Select_Item_List.
   function To_Select_Item_List (Object : in Util.Beans.Objects.Object) return Select_Item_List;

   --  Get the number of elements in the list.
   overriding
   function Get_Count (From : in Select_Item_List) return Natural;

   --  Set the current row index.  Valid row indexes start at 1.
   overriding
   procedure Set_Row_Index (From  : in out Select_Item_List;
                            Index : in Natural);

   --  Get the element at the current row index.
   overriding
   function Get_Row (From  : in Select_Item_List) return Util.Beans.Objects.Object;

   --  Get the number of items in the list.
   function Length (List : in Select_Item_List) return Natural;

   --  Get the select item from the list
   function Get_Select_Item (List : in Select_Item_List'Class;
                             Pos  : in Positive) return Select_Item;

   --  Add the item at the end of the list.
   procedure Append (List : in out Select_Item_List;
                     Item : in Select_Item'Class);

   --  Add the item at the end of the list.  This is a shortcut for
   --  Append (Create_List_Item (Label, Value))
   procedure Append (List  : in out Select_Item_List;
                     Label : in String;
                     Value : in String);

private

   use Ada.Strings.Wide_Wide_Unbounded;

   type Select_Item_Record is limited record
      Label       : Unbounded_Wide_Wide_String;
      Value       : Unbounded_Wide_Wide_String;
      Description : Unbounded_Wide_Wide_String;
      Disabled    : Boolean := False;
      Escape      : Boolean := False;
   end record;
   type Select_Item_Record_Access is access all Select_Item_Record;

   package Select_Item_Refs is
      new Util.Refs.General_References (Element_Type   => Select_Item_Record);
   subtype Select_Item_Record_Accessor is Select_Item_Refs.Element_Accessor;

   type Select_Item is new Util.Beans.Basic.Readonly_Bean with record
      Item : Select_Item_Refs.Ref;
   end record;

   package Select_Item_Vectors is
      new Ada.Containers.Vectors (Index_Type   => Positive,
                                  Element_Type => Select_Item);

   type Select_Item_Vector is new Util.Refs.Ref_Entity with record
      List  : Select_Item_Vectors.Vector;
   end record;
   type Select_Item_Vector_Access is access all Select_Item_Vector;

   package Select_Item_Vector_Refs is
      new Util.Refs.References (Element_Type   => Select_Item_Vector,
                                Element_Access => Select_Item_Vector_Access);

   type Select_Item_List is new Util.Beans.Basic.List_Bean with record
      List    : Select_Item_Vector_Refs.Ref;
      Current : aliased Select_Item;
      Row     : Util.Beans.Objects.Object;
   end record;

   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   overriding
   function Get_Value (From : in Select_Item_List;
                       Name : in String) return Util.Beans.Objects.Object;

end ASF.Models.Selects;

Update to use General_References generic package


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

with Util.Log.Loggers;
with Util.Files;
with Util.Systems.Os;
with Util.Streams.Raw;
with Util.Systems.Types;
with Util.Systems.Os;
with Interfaces;

with Babel.Streams.Files;
package body Babel.Stores.Local is

   function Errno return Integer;
   pragma Import (C, errno, "__get_errno");

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Babel.Stores.Local");

   function Get_File_Size (Ent : in Ada.Directories.Directory_Entry_Type) return Babel.Files.File_Size is
      Size : Ada.Directories.File_Size;
   begin
      Size := Ada.Directories.Size (Ent);
      return Babel.Files.File_Size (Size);

   exception
      when Constraint_Error =>
         return Babel.Files.File_Size (Interfaces.Unsigned_32'Last);
   end Get_File_Size;

   --  ------------------------------
   --  Get the absolute path to access the local file.
   --  ------------------------------
   function Get_Absolute_Path (Store : in Local_Store_Type;
                               Path  : in String) return String is
   begin
      if Ada.Strings.Unbounded.Length (Store.Root_Dir) = 0 then
         return Path;
      else
         return Util.Files.Compose (Ada.Strings.Unbounded.To_String (Store.Root_Dir), Path);
      end if;
   end Get_Absolute_Path;

   --  Open a file in the store to read its content with a stream.
   overriding
   procedure Open_File (Store  : in out Local_Store_Type;
                        Path   : in String;
                        Stream : out Babel.Streams.Stream_Access) is
   begin
      null;
   end Open_File;

   --  ------------------------------
   --  Open a file in the store to read its content with a stream.
   --  ------------------------------
   overriding
   procedure Read_File (Store  : in out Local_Store_Type;
                        Path   : in String;
                        Stream : out Babel.Streams.Refs.Stream_Ref) is
      Abs_Path : constant String := Store.Get_Absolute_Path (Path);
      File     : Babel.Streams.Files.Stream_Access := new Babel.Streams.Files.Stream_Type;
      Buffer   : Babel.Files.Buffers.Buffer_Access;
   begin
      Log.Info ("Read file {0}", Abs_Path);

      Stream := Babel.Streams.Refs.Stream_Refs.Create (File.all'Access);
      Store.Pool.Get_Buffer (Buffer);
      File.Open (Abs_Path, Buffer);
   end Read_File;

   --  ------------------------------
   --  Write a file in the store with a stream.
   --  ------------------------------
   overriding
   procedure Write_File (Store  : in out Local_Store_Type;
                         Path   : in String;
                         Stream : in Babel.Streams.Refs.Stream_Ref;
                         Mode   : in Babel.Files.File_Mode) is
      Abs_Path   : constant String := Store.Get_Absolute_Path (Path);
      File       : Babel.Streams.Files.Stream_Access := new Babel.Streams.Files.Stream_Type;
      Output     : Babel.Streams.Refs.Stream_Ref;
   begin
      Log.Info ("Write file {0}", Abs_Path);

      Output := Babel.Streams.Refs.Stream_Refs.Create (File.all'Access);
      File.Create (Abs_Path, Mode);
      Babel.Streams.Refs.Copy (From => Stream,
                               Into => Output);
   end Write_File;

   procedure Read (Store : in out Local_Store_Type;
                   Path  : in String;
                   Into  : in out Babel.Files.Buffers.Buffer) is
      use Ada.Strings.Unbounded;
      use type Ada.Streams.Stream_Element_Offset;

      File     : Ada.Streams.Stream_IO.File_Type;
      Abs_Path : constant String := Store.Get_Absolute_Path (Path);
   begin
      Ada.Streams.Stream_IO.Open (File, Ada.Streams.Stream_IO.In_File, Abs_Path);
      Ada.Streams.Stream_IO.Read (File, Into.Data, Into.Last);
      Ada.Streams.Stream_IO.Close (File);
      Log.Info ("Read {0} -> {1}", Abs_Path, Ada.Streams.Stream_Element_Offset'Image (Into.Last));
   end Read;

   procedure Open (Store  : in out Local_Store_Type;
                   Stream : in out Util.Streams.Raw.Raw_Stream;
                   Path   : in String) is
      use Util.Systems.Os;
      use type Interfaces.C.int;

      File : Util.Systems.Os.File_Type;
      Name : Util.Systems.Os.Ptr := Interfaces.C.Strings.New_String (Path);
   begin
      File := Util.Systems.Os.Sys_Open (Name, O_CREAT + O_WRONLY, 8#644#);
      if File < 0 then
         if Errno = System.OS_Constants.ENOENT then
            declare
               Dir : constant String := Ada.Directories.Containing_Directory (Path);
            begin
               Ada.Directories.Create_Path (Dir);
            end;
            File := Util.Systems.Os.Sys_Open (Name, O_CREAT + O_WRONLY, 8#644#);
         end if;
      end if;
      if File < 0 then
         Log.Error ("Cannot create {0}", Path);
         raise Ada.Streams.Stream_IO.Name_Error with "Cannot create " & Path;
      end if;
      Stream.Initialize (File);
      Interfaces.C.Strings.Free (Name);
   end Open;

   procedure Write (Store : in out Local_Store_Type;
                    Path  : in String;
                    Into  : in Babel.Files.Buffers.Buffer) is
      use Ada.Strings.Unbounded;
      use type Ada.Streams.Stream_Element_Offset;

      Abs_Path : constant String := Store.Get_Absolute_Path (Path);
      Stream   : Util.Streams.Raw.Raw_Stream;
   begin
      Log.Info ("Write {0}", Abs_Path);

      Store.Open (Stream, Abs_Path);
      Stream.Write (Into.Data (Into.Data'First .. Into.Last));
      Stream.Close;
   end Write;

   procedure Scan (Store  : in out Local_Store_Type;
                   Path   : in String;
                   Into   : in out Babel.Files.File_Container'Class;
                   Filter : in Babel.Filters.Filter_Type'Class) is
      use Ada.Directories;
      use type Babel.Files.File_Type;
      use type Babel.Files.Directory_Type;

      function Sys_Stat (Path : in System.Address;
                         Stat : access Util.Systems.Types.Stat_Type) return Integer;
      pragma Import (C, Sys_Stat, "stat");

      Search_Filter : constant Ada.Directories.Filter_Type := (Ordinary_File => True,
                                                               Ada.Directories.Directory => True,
                                                               Special_File => False);
      Search   : Search_Type;
      Ent      : Directory_Entry_Type;
      Stat     : aliased Util.Systems.Types.Stat_Type;
   begin
      Log.Info ("Scan directory {0}", Path);

      Start_Search (Search, Directory => Path, Pattern => "*", Filter => Search_Filter);
      while More_Entries (Search) loop
         Get_Next_Entry (Search, Ent);
         declare
            use Util.Systems.Types;
            use Interfaces.C;
            use Babel.Files;

            Name : constant String    := Simple_Name (Ent);
            Kind : constant File_Kind := Ada.Directories.Kind (Ent);
            File : Babel.Files.File_Type;
            Dir  : Babel.Files.Directory_Type;
            Res  : Integer;
            Fpath : String (1 .. Path'Length + Name'Length + 3);
         begin
            Fpath (Path'Range) := Path;
            Fpath (Path'Last + 1) := '/';
            Fpath (Path'Last + 2 .. Path'Last + 2 + Name'Length - 1) := Name;
            Fpath (Path'Last + 2 + Name'Length) := ASCII.NUL;
            Res := Sys_Stat (Fpath'Address, Stat'Unchecked_Access);
            if (Stat.st_mode and S_IFMT) = S_IFREG then
               if Filter.Is_Accepted (Kind, Path, Name) then
                  File := Into.Find (Name);
                  if File = Babel.Files.NO_FILE then
                     File := Into.Create (Name);
                  end if;
                  Babel.Files.Set_Size (File, Babel.Files.File_Size (Stat.st_size));
                  Babel.Files.Set_Owner (File, Uid_Type (Stat.st_uid), Gid_Type (Stat.st_gid));
                  Babel.Files.Set_Date (File, Stat.st_mtim);
                  Log.Debug ("Adding {0}", Name);
                  Into.Add_File (File);
               end if;
            elsif Name /= "." and Name /= ".." and Filter.Is_Accepted (Kind, Path, Name) then
               Dir := Into.Find (Name);
               if Dir = Babel.Files.NO_DIRECTORY then
                  Dir := Into.Create (Name);
               end if;
               Into.Add_Directory (Dir);
            end if;
         end;
      end loop;

   exception
      when E : others =>
         Log.Error ("Exception ", E);
   end Scan;

   --  ------------------------------
   --  Set the root directory for the local store.
   --  ------------------------------
   procedure Set_Root_Directory (Store : in out Local_Store_Type;
                                 Path  : in String) is
   begin
      Store.Root_Dir := Ada.Strings.Unbounded.To_Unbounded_String (Path);
   end Set_Root_Directory;

   --  ------------------------------
   --  Set the buffer pool to be used by local store.
   --  ------------------------------
   procedure Set_Buffers (Store   : in out Local_Store_Type;
                          Buffers : in Babel.Files.Buffers.Buffer_Pool_Access) is
   begin
      Store.Pool := Buffers;
   end Set_Buffers;

end Babel.Stores.Local;

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

with Util.Log.Loggers;
with Util.Files;
with Util.Systems.Os;
with Util.Streams.Raw;
with Util.Systems.Types;
with Util.Systems.Os;
with Interfaces;

with Babel.Streams.Files;
package body Babel.Stores.Local is

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Babel.Stores.Local");

   function Get_File_Size (Ent : in Ada.Directories.Directory_Entry_Type) return Babel.Files.File_Size is
      Size : Ada.Directories.File_Size;
   begin
      Size := Ada.Directories.Size (Ent);
      return Babel.Files.File_Size (Size);

   exception
      when Constraint_Error =>
         return Babel.Files.File_Size (Interfaces.Unsigned_32'Last);
   end Get_File_Size;

   --  ------------------------------
   --  Get the absolute path to access the local file.
   --  ------------------------------
   function Get_Absolute_Path (Store : in Local_Store_Type;
                               Path  : in String) return String is
   begin
      if Ada.Strings.Unbounded.Length (Store.Root_Dir) = 0 then
         return Path;
      else
         return Util.Files.Compose (Ada.Strings.Unbounded.To_String (Store.Root_Dir), Path);
      end if;
   end Get_Absolute_Path;

   --  Open a file in the store to read its content with a stream.
   overriding
   procedure Open_File (Store  : in out Local_Store_Type;
                        Path   : in String;
                        Stream : out Babel.Streams.Stream_Access) is
   begin
      null;
   end Open_File;

   --  ------------------------------
   --  Open a file in the store to read its content with a stream.
   --  ------------------------------
   overriding
   procedure Read_File (Store  : in out Local_Store_Type;
                        Path   : in String;
                        Stream : out Babel.Streams.Refs.Stream_Ref) is
      Abs_Path : constant String := Store.Get_Absolute_Path (Path);
      File     : Babel.Streams.Files.Stream_Access := new Babel.Streams.Files.Stream_Type;
      Buffer   : Babel.Files.Buffers.Buffer_Access;
   begin
      Log.Info ("Read file {0}", Abs_Path);

      Stream := Babel.Streams.Refs.Stream_Refs.Create (File.all'Access);
      Store.Pool.Get_Buffer (Buffer);
      File.Open (Abs_Path, Buffer);
   end Read_File;

   --  ------------------------------
   --  Write a file in the store with a stream.
   --  ------------------------------
   overriding
   procedure Write_File (Store  : in out Local_Store_Type;
                         Path   : in String;
                         Stream : in Babel.Streams.Refs.Stream_Ref;
                         Mode   : in Babel.Files.File_Mode) is
      Abs_Path   : constant String := Store.Get_Absolute_Path (Path);
      File       : Babel.Streams.Files.Stream_Access := new Babel.Streams.Files.Stream_Type;
      Output     : Babel.Streams.Refs.Stream_Ref;
   begin
      Log.Info ("Write file {0}", Abs_Path);

      Output := Babel.Streams.Refs.Stream_Refs.Create (File.all'Access);
      File.Create (Abs_Path, Mode);
      Babel.Streams.Refs.Copy (From => Stream,
                               Into => Output);
   end Write_File;

   procedure Read (Store : in out Local_Store_Type;
                   Path  : in String;
                   Into  : in out Babel.Files.Buffers.Buffer) is
      use Ada.Strings.Unbounded;
      use type Ada.Streams.Stream_Element_Offset;

      File     : Ada.Streams.Stream_IO.File_Type;
      Abs_Path : constant String := Store.Get_Absolute_Path (Path);
   begin
      Ada.Streams.Stream_IO.Open (File, Ada.Streams.Stream_IO.In_File, Abs_Path);
      Ada.Streams.Stream_IO.Read (File, Into.Data, Into.Last);
      Ada.Streams.Stream_IO.Close (File);
      Log.Info ("Read {0} -> {1}", Abs_Path, Ada.Streams.Stream_Element_Offset'Image (Into.Last));
   end Read;

   procedure Open (Store  : in out Local_Store_Type;
                   Stream : in out Util.Streams.Raw.Raw_Stream;
                   Path   : in String) is
      use Util.Systems.Os;
      use type Interfaces.C.int;

      File : Util.Systems.Os.File_Type;
      Name : Util.Systems.Os.Ptr := Interfaces.C.Strings.New_String (Path);
   begin
      File := Util.Systems.Os.Sys_Open (Name, O_CREAT + O_WRONLY, 8#644#);
      if File < 0 then
         if Errno = System.OS_Constants.ENOENT then
            declare
               Dir : constant String := Ada.Directories.Containing_Directory (Path);
            begin
               Ada.Directories.Create_Path (Dir);
            end;
            File := Util.Systems.Os.Sys_Open (Name, O_CREAT + O_WRONLY, 8#644#);
         end if;
      end if;
      if File < 0 then
         Log.Error ("Cannot create {0}", Path);
         raise Ada.Streams.Stream_IO.Name_Error with "Cannot create " & Path;
      end if;
      Stream.Initialize (File);
      Interfaces.C.Strings.Free (Name);
   end Open;

   procedure Write (Store : in out Local_Store_Type;
                    Path  : in String;
                    Into  : in Babel.Files.Buffers.Buffer) is
      use Ada.Strings.Unbounded;
      use type Ada.Streams.Stream_Element_Offset;

      Abs_Path : constant String := Store.Get_Absolute_Path (Path);
      Stream   : Util.Streams.Raw.Raw_Stream;
   begin
      Log.Info ("Write {0}", Abs_Path);

      Store.Open (Stream, Abs_Path);
      Stream.Write (Into.Data (Into.Data'First .. Into.Last));
      Stream.Close;
   end Write;

   procedure Scan (Store  : in out Local_Store_Type;
                   Path   : in String;
                   Into   : in out Babel.Files.File_Container'Class;
                   Filter : in Babel.Filters.Filter_Type'Class) is
      use Ada.Directories;
      use type Babel.Files.File_Type;
      use type Babel.Files.Directory_Type;

      function Sys_Stat (Path : in System.Address;
                         Stat : access Util.Systems.Types.Stat_Type) return Integer;
      pragma Import (C, Sys_Stat, "stat");

      Search_Filter : constant Ada.Directories.Filter_Type := (Ordinary_File => True,
                                                               Ada.Directories.Directory => True,
                                                               Special_File => False);
      Search   : Search_Type;
      Ent      : Directory_Entry_Type;
      Stat     : aliased Util.Systems.Types.Stat_Type;
   begin
      Log.Info ("Scan directory {0}", Path);

      Start_Search (Search, Directory => Path, Pattern => "*", Filter => Search_Filter);
      while More_Entries (Search) loop
         Get_Next_Entry (Search, Ent);
         declare
            use Util.Systems.Types;
            use Interfaces.C;
            use Babel.Files;

            Name : constant String    := Simple_Name (Ent);
            Kind : constant File_Kind := Ada.Directories.Kind (Ent);
            File : Babel.Files.File_Type;
            Dir  : Babel.Files.Directory_Type;
            Res  : Integer;
            Fpath : String (1 .. Path'Length + Name'Length + 3);
         begin
            Fpath (Path'Range) := Path;
            Fpath (Path'Last + 1) := '/';
            Fpath (Path'Last + 2 .. Path'Last + 2 + Name'Length - 1) := Name;
            Fpath (Path'Last + 2 + Name'Length) := ASCII.NUL;
            Res := Sys_Stat (Fpath'Address, Stat'Unchecked_Access);
            if (Stat.st_mode and S_IFMT) = S_IFREG then
               if Filter.Is_Accepted (Kind, Path, Name) then
                  File := Into.Find (Name);
                  if File = Babel.Files.NO_FILE then
                     File := Into.Create (Name);
                  end if;
                  Babel.Files.Set_Size (File, Babel.Files.File_Size (Stat.st_size));
                  Babel.Files.Set_Owner (File, Uid_Type (Stat.st_uid), Gid_Type (Stat.st_gid));
                  Babel.Files.Set_Date (File, Stat.st_mtim);
                  Log.Debug ("Adding {0}", Name);
                  Into.Add_File (File);
               end if;
            elsif Name /= "." and Name /= ".." and Filter.Is_Accepted (Kind, Path, Name) then
               Dir := Into.Find (Name);
               if Dir = Babel.Files.NO_DIRECTORY then
                  Dir := Into.Create (Name);
               end if;
               Into.Add_Directory (Dir);
            end if;
         end;
      end loop;

   exception
      when E : others =>
         Log.Error ("Exception ", E);
   end Scan;

   --  ------------------------------
   --  Set the root directory for the local store.
   --  ------------------------------
   procedure Set_Root_Directory (Store : in out Local_Store_Type;
                                 Path  : in String) is
   begin
      Store.Root_Dir := Ada.Strings.Unbounded.To_Unbounded_String (Path);
   end Set_Root_Directory;

   --  ------------------------------
   --  Set the buffer pool to be used by local store.
   --  ------------------------------
   procedure Set_Buffers (Store   : in out Local_Store_Type;
                          Buffers : in Babel.Files.Buffers.Buffer_Pool_Access) is
   begin
      Store.Pool := Buffers;
   end Set_Buffers;

end Babel.Stores.Local;

Remove declaration of Errno function

Remove declaration of Errno function


-----------------------------------------------------------------------
--  gen-model-mappings -- Type mappings for Code Generator
--  Copyright (C) 2011, 2012, 2015, 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 Util.Log.Loggers;

--  The Gen.Model.Mappings package controls the mappings to convert an XML
--  type into the Ada type.
package body Gen.Model.Mappings is

   use Ada.Strings.Unbounded;

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Gen.Model.Mappings");

   Types : Mapping_Maps.Map;

   Mapping_Name : Unbounded_String;

   --  ------------------------------
   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   --  ------------------------------
   overriding
   function Get_Value (From : in Mapping_Definition;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "name" then
         return Util.Beans.Objects.To_Object (From.Target);
      elsif Name = "isBoolean" then
         return Util.Beans.Objects.To_Object (From.Kind = T_BOOLEAN);
      elsif Name = "isInteger" then
         return Util.Beans.Objects.To_Object (From.Kind = T_INTEGER or From.Kind = T_ENTITY_TYPE);
      elsif Name = "isString" then
         return Util.Beans.Objects.To_Object (From.Kind = T_STRING);
      elsif Name = "isIdentifier" then
         return Util.Beans.Objects.To_Object (From.Kind = T_IDENTIFIER);
      elsif Name = "isDate" then
         return Util.Beans.Objects.To_Object (From.Kind = T_DATE);
      elsif Name = "isBlob" then
         return Util.Beans.Objects.To_Object (From.Kind = T_BLOB);
      elsif Name = "isEnum" then
         return Util.Beans.Objects.To_Object (From.Kind = T_ENUM);
      elsif Name = "isPrimitiveType" then
         return Util.Beans.Objects.To_Object (From.Kind /= T_TABLE and From.Kind /= T_BLOB);
      elsif Name = "isNullable" then
         return Util.Beans.Objects.To_Object (From.Nullable);
      else
         return Definition (From).Get_Value (Name);
      end if;
   end Get_Value;

   --  ------------------------------
   --  Get the type name.
   --  ------------------------------
   function Get_Type_Name (From : Mapping_Definition) return String is
   begin
      case From.Kind is
         when T_BOOLEAN =>
            return "boolean";

         when T_INTEGER =>
            return "integer";

         when T_DATE =>
            return "date";

         when T_IDENTIFIER =>
            return "identifier";

         when T_STRING =>
            return "string";

         when T_ENTITY_TYPE =>
            return "entity_type";

         when T_BLOB =>
            return "blob";

         when T_ENUM =>
            return From.Get_Name;

         when others =>
            return From.Get_Name;

      end case;
   end Get_Type_Name;

   --  ------------------------------
   --  Find the mapping for the given type name.
   --  ------------------------------
   function Find_Type (Name       : in Ada.Strings.Unbounded.Unbounded_String;
                       Allow_Null : in Boolean)
                       return Mapping_Definition_Access is
      Pos : constant Mapping_Maps.Cursor := Types.Find (Mapping_Name & Name);
   begin
      if not Mapping_Maps.Has_Element (Pos) then
         Log.Info ("Type '{0}' not found in mapping table '{1}'",
                   To_String (Name), To_String (Mapping_Name));
         return null;
      elsif Allow_Null then
         if Mapping_Maps.Element (Pos).Allow_Null = null then
            Log.Info ("Type '{0}' does not allow a null value in mapping table '{1}'",
                       To_String (Name), To_String (Mapping_Name));
            return Mapping_Maps.Element (Pos);
         end if;
         return Mapping_Maps.Element (Pos).Allow_Null;
      else
         return Mapping_Maps.Element (Pos);
      end if;
   end Find_Type;

   procedure Register_Type (Name    : in String;
                            Mapping : in Mapping_Definition_Access;
                            Kind    : in Basic_Type) is
      N    : constant Unbounded_String := Mapping_Name & To_Unbounded_String (Name);
      Pos  : constant Mapping_Maps.Cursor := Types.Find (N);
   begin
      Log.Debug ("Register type '{0}'", Name);

      if not Mapping_Maps.Has_Element (Pos) then
         Mapping.Kind := Kind;
         Types.Insert (N, Mapping);
      end if;
   end Register_Type;

   --  ------------------------------
   --  Register a type mapping From that is mapped to Target.
   --  ------------------------------
   procedure Register_Type (Target     : in String;
                            From       : in String;
                            Kind       : in Basic_Type;
                            Allow_Null : in Boolean) is
      Name    : constant Unbounded_String := Mapping_Name & To_Unbounded_String (From);
      Pos     : constant Mapping_Maps.Cursor := Types.Find (Name);
      Mapping : Mapping_Definition_Access;
      Found   : Boolean;
   begin
      Log.Debug ("Register type '{0}' mapped to '{1}' type {2}",
                 From, Target, Basic_Type'Image (Kind));

      Found := Mapping_Maps.Has_Element (Pos);
      if Found then
         Mapping := Mapping_Maps.Element (Pos);
      else
         Mapping := new Mapping_Definition;
         Mapping.Set_Name (From);
         Types.Insert (Name, Mapping);
      end if;
      if Allow_Null then
         Mapping.Allow_Null := new Mapping_Definition;
         Mapping.Allow_Null.Target := To_Unbounded_String (Target);
         Mapping.Allow_Null.Kind := Kind;
         Mapping.Allow_Null.Nullable := True;
         if not Found then
            Mapping.Target := To_Unbounded_String (Target);
            Mapping.Kind   := Kind;
         end if;
      else
         Mapping.Target := To_Unbounded_String (Target);
         Mapping.Kind   := Kind;
      end if;
   end Register_Type;

   --  ------------------------------
   --  Setup the type mapping for the language identified by the given name.
   --  ------------------------------
   procedure Set_Mapping_Name (Name : in String) is
   begin
      Log.Info ("Using type mapping {0}", Name);

      Mapping_Name := To_Unbounded_String (Name & ".");
   end Set_Mapping_Name;

end Gen.Model.Mappings;

-----------------------------------------------------------------------
--  gen-model-mappings -- Type mappings for Code Generator
--  Copyright (C) 2011, 2012, 2015, 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 Util.Log.Loggers;

--  The Gen.Model.Mappings package controls the mappings to convert an XML
--  type into the Ada type.
package body Gen.Model.Mappings is

   use Ada.Strings.Unbounded;

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Gen.Model.Mappings");

   Types : Mapping_Maps.Map;

   Mapping_Name : Unbounded_String;

   --  ------------------------------
   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   --  ------------------------------
   overriding
   function Get_Value (From : in Mapping_Definition;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "name" then
         return Util.Beans.Objects.To_Object (From.Target);
      elsif Name = "isBoolean" then
         return Util.Beans.Objects.To_Object (From.Kind = T_BOOLEAN);
      elsif Name = "isInteger" then
         return Util.Beans.Objects.To_Object (From.Kind = T_INTEGER or From.Kind = T_ENTITY_TYPE);
      elsif Name = "isString" then
         return Util.Beans.Objects.To_Object (From.Kind = T_STRING);
      elsif Name = "isIdentifier" then
         return Util.Beans.Objects.To_Object (From.Kind = T_IDENTIFIER);
      elsif Name = "isDate" then
         return Util.Beans.Objects.To_Object (From.Kind = T_DATE);
      elsif Name = "isBlob" then
         return Util.Beans.Objects.To_Object (From.Kind = T_BLOB);
      elsif Name = "isEnum" then
         return Util.Beans.Objects.To_Object (From.Kind = T_ENUM);
      elsif Name = "isPrimitiveType" then
         return Util.Beans.Objects.To_Object (From.Kind /= T_TABLE and From.Kind /= T_BLOB);
      elsif Name = "isNullable" then
         return Util.Beans.Objects.To_Object (From.Nullable);
      else
         return Definition (From).Get_Value (Name);
      end if;
   end Get_Value;

   --  ------------------------------
   --  Get the type name.
   --  ------------------------------
   function Get_Type_Name (From : Mapping_Definition) return String is
   begin
      case From.Kind is
         when T_BOOLEAN =>
            return "boolean";

         when T_INTEGER =>
            return "integer";

         when T_DATE =>
            return "date";

         when T_IDENTIFIER =>
            return "identifier";

         when T_STRING =>
            return "string";

         when T_ENTITY_TYPE =>
            return "entity_type";

         when T_BLOB =>
            return "blob";

         when T_ENUM =>
            return From.Get_Name;

         when others =>
            return From.Get_Name;

      end case;
   end Get_Type_Name;

   --  ------------------------------
   --  Find the mapping for the given type name.
   --  ------------------------------
   function Find_Type (Name       : in Ada.Strings.Unbounded.Unbounded_String;
                       Allow_Null : in Boolean)
                       return Mapping_Definition_Access is
      Pos : constant Mapping_Maps.Cursor := Types.Find (Mapping_Name & Name);
   begin
      if not Mapping_Maps.Has_Element (Pos) then
         Log.Info ("Type '{0}' not found in mapping table '{1}'",
                   To_String (Name), To_String (Mapping_Name));
         return null;
      elsif Allow_Null then
         if Mapping_Maps.Element (Pos).Allow_Null = null then
            Log.Info ("Type '{0}' does not allow a null value in mapping table '{1}'",
                       To_String (Name), To_String (Mapping_Name));
            return Mapping_Maps.Element (Pos);
         end if;
         return Mapping_Maps.Element (Pos).Allow_Null;
      else
         return Mapping_Maps.Element (Pos);
      end if;
   end Find_Type;

   --  ------------------------------
   --  Get the type name according to the mapping definition.
   --  ------------------------------
   function Get_Type_Name (Name : in Ada.Strings.Unbounded.Unbounded_String) return String is
      T : constant Mapping_Definition_Access := Find_Type (Name, False);
   begin
      if T = null then
         return To_String (Name);
      else
         return To_String (T.Target);
      end if;
   end Get_Type_Name;

   procedure Register_Type (Name    : in String;
                            Mapping : in Mapping_Definition_Access;
                            Kind    : in Basic_Type) is
      N    : constant Unbounded_String := Mapping_Name & To_Unbounded_String (Name);
      Pos  : constant Mapping_Maps.Cursor := Types.Find (N);
   begin
      Log.Debug ("Register type '{0}'", Name);

      if not Mapping_Maps.Has_Element (Pos) then
         Mapping.Kind := Kind;
         Types.Insert (N, Mapping);
      end if;
   end Register_Type;

   --  ------------------------------
   --  Register a type mapping From that is mapped to Target.
   --  ------------------------------
   procedure Register_Type (Target     : in String;
                            From       : in String;
                            Kind       : in Basic_Type;
                            Allow_Null : in Boolean) is
      Name    : constant Unbounded_String := Mapping_Name & To_Unbounded_String (From);
      Pos     : constant Mapping_Maps.Cursor := Types.Find (Name);
      Mapping : Mapping_Definition_Access;
      Found   : Boolean;
   begin
      Log.Debug ("Register type '{0}' mapped to '{1}' type {2}",
                 From, Target, Basic_Type'Image (Kind));

      Found := Mapping_Maps.Has_Element (Pos);
      if Found then
         Mapping := Mapping_Maps.Element (Pos);
      else
         Mapping := new Mapping_Definition;
         Mapping.Set_Name (From);
         Types.Insert (Name, Mapping);
      end if;
      if Allow_Null then
         Mapping.Allow_Null := new Mapping_Definition;
         Mapping.Allow_Null.Target := To_Unbounded_String (Target);
         Mapping.Allow_Null.Kind := Kind;
         Mapping.Allow_Null.Nullable := True;
         if not Found then
            Mapping.Target := To_Unbounded_String (Target);
            Mapping.Kind   := Kind;
         end if;
      else
         Mapping.Target := To_Unbounded_String (Target);
         Mapping.Kind   := Kind;
      end if;
   end Register_Type;

   --  ------------------------------
   --  Setup the type mapping for the language identified by the given name.
   --  ------------------------------
   procedure Set_Mapping_Name (Name : in String) is
   begin
      Log.Info ("Using type mapping {0}", Name);

      Mapping_Name := To_Unbounded_String (Name & ".");
   end Set_Mapping_Name;

end Gen.Model.Mappings;

Implement Get_Type_Name function

Implement Get_Type_Name function


-----------------------------------------------------------------------
--  EL.Expressions -- Expression Language
--  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.
-----------------------------------------------------------------------

--
--  First, create the expression object:
--
--    E : constant Expression := EL.Expressions.Create_Expression ("obj.count + 3");
--
--  The expression must be evaluated against an expression context.
--  The expression context will resolve variables whose values can change depending
--  on the evaluation context.  In the example, ''obj'' is the variable name
--  and ''count'' is the property associated with that variable.
--
--    Value : constant Object := E.Get_Value (Context);
--
--  The ''Value'' holds the result which can be a boolean, an integer, a date,
--  a float number or a string.  The value can be converted as follows:
--
--    N : Integer := To_Integer (Value);
--

with EL.Objects;
with Ada.Finalization;

limited with EL.Expressions.Nodes;
with EL.Contexts;
with EL.Beans;
package EL.Expressions is

   use EL.Objects;
   use EL.Contexts;

   --  Exception raised when parsing an invalid expression.
   Invalid_Expression : exception;

   --  Exception raised when a variable cannot be resolved.
   Invalid_Variable : exception;

   --  ------------------------------
   --  Expression
   --  ------------------------------
   type Expression is new Ada.Finalization.Controlled with private;

   --  Get the value of the expression using the given expression context.
   --  Returns an object that holds a typed result.
   function Get_Value (Expr    : Expression;
                       Context : ELContext'Class) return Object;

   --  Parse an expression and return its representation ready for evaluation.
   --  The context is used to resolve the functions.  Variables will be
   --  resolved during evaluation of the expression.
   --  Raises <b>Invalid_Expression</b> if the expression is invalid.
   function Create_Expression (Expr    : String;
                               Context : ELContext'Class)
                               return Expression;

   --  ------------------------------
   --  ValueExpression
   --  ------------------------------   --
   type ValueExpression is new Expression with private;
   type ValueExpression_Access is access all ValueExpression'Class;

   --  Get the value of the expression using the given expression context.
   --  Returns an object that holds a typed result.
   overriding
   function Get_Value (Expr    : in ValueExpression;
                       Context : in ELContext'Class) return Object;

   procedure Set_Value (Expr    : in ValueExpression;
                        Context : in ELContext'Class;
                        Value   : in Object);

   function Is_Readonly (Expr : in ValueExpression) return Boolean;

   --  Parse an expression and return its representation ready for evaluation.
   function Create_Expression (Expr    : String;
                               Context : ELContext'Class)
                               return ValueExpression;

   function Create_ValueExpression (Bean : access EL.Beans.Readonly_Bean'Class)
                                    return ValueExpression;

private

   procedure Adjust   (Object : in out Expression);
   procedure Finalize (Object : in out Expression);

   type Expression is new Ada.Finalization.Controlled with record
      Node : access EL.Expressions.Nodes.ELNode'Class;
   end record;

   type ValueExpression is new Expression with record
      Bean : access EL.Beans.Readonly_Bean'Class;
   end record;

end EL.Expressions;

-----------------------------------------------------------------------
--  EL.Expressions -- Expression Language
--  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.
-----------------------------------------------------------------------

--
--  First, create the expression object:
--
--    E : constant Expression := EL.Expressions.Create_Expression ("obj.count + 3");
--
--  The expression must be evaluated against an expression context.
--  The expression context will resolve variables whose values can change depending
--  on the evaluation context.  In the example, ''obj'' is the variable name
--  and ''count'' is the property associated with that variable.
--
--    Value : constant Object := E.Get_Value (Context);
--
--  The ''Value'' holds the result which can be a boolean, an integer, a date,
--  a float number or a string.  The value can be converted as follows:
--
--    N : Integer := To_Integer (Value);
--

with EL.Objects;
with Ada.Finalization;

limited with EL.Expressions.Nodes;
with EL.Contexts;
with EL.Beans;
package EL.Expressions is

   use EL.Objects;
   use EL.Contexts;

   --  Exception raised when parsing an invalid expression.
   Invalid_Expression : exception;

   --  Exception raised when a variable cannot be resolved.
   Invalid_Variable : exception;

   --  ------------------------------
   --  Expression
   --  ------------------------------
   type Expression is new Ada.Finalization.Controlled with private;
   type Expression_Access is access all Expression'Class;

   --  Get the value of the expression using the given expression context.
   --  Returns an object that holds a typed result.
   function Get_Value (Expr    : Expression;
                       Context : ELContext'Class) return Object;

   --  Parse an expression and return its representation ready for evaluation.
   --  The context is used to resolve the functions.  Variables will be
   --  resolved during evaluation of the expression.
   --  Raises <b>Invalid_Expression</b> if the expression is invalid.
   function Create_Expression (Expr    : String;
                               Context : ELContext'Class)
                               return Expression;

   --  ------------------------------
   --  ValueExpression
   --  ------------------------------   --
   type ValueExpression is new Expression with private;
   type ValueExpression_Access is access all ValueExpression'Class;

   --  Get the value of the expression using the given expression context.
   --  Returns an object that holds a typed result.
   overriding
   function Get_Value (Expr    : in ValueExpression;
                       Context : in ELContext'Class) return Object;

   procedure Set_Value (Expr    : in ValueExpression;
                        Context : in ELContext'Class;
                        Value   : in Object);

   function Is_Readonly (Expr : in ValueExpression) return Boolean;

   --  Parse an expression and return its representation ready for evaluation.
   function Create_Expression (Expr    : String;
                               Context : ELContext'Class)
                               return ValueExpression;

   function Create_ValueExpression (Bean : access EL.Beans.Readonly_Bean'Class)
                                    return ValueExpression;

private

   procedure Adjust   (Object : in out Expression);
   procedure Finalize (Object : in out Expression);

   type Expression is new Ada.Finalization.Controlled with record
      Node : access EL.Expressions.Nodes.ELNode'Class;
   end record;

   type ValueExpression is new Expression with record
      Bean : access EL.Beans.Readonly_Bean'Class;
   end record;

end EL.Expressions;

Declare Expression_Access

Declare Expression_Access


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

package body Wiki.Attributes is

   use Ada.Characters;

   --  ------------------------------
   --  Get the attribute name.
   --  ------------------------------
   function Get_Name (Position : in Cursor) return String is
      Attr : constant Attribute_Access := Attribute_Vectors.Element (Position.Pos);
   begin
      return Attr.Name;
   end Get_Name;

   --  ------------------------------
   --  Get the attribute value.
   --  ------------------------------
   function Get_Value (Position : in Cursor) return String is
      Attr : constant Attribute_Access := Attribute_Vectors.Element (Position.Pos);
   begin
      return Ada.Characters.Conversions.To_String (Attr.Value);
   end Get_Value;

   --  ------------------------------
   --  Get the attribute wide value.
   --  ------------------------------
   function Get_Wide_Value (Position : in Cursor) return Wide_Wide_String is
      Attr : constant Attribute_Access := Attribute_Vectors.Element (Position.Pos);
   begin
      return Attr.Value;
   end Get_Wide_Value;

   --  ------------------------------
   --  Get the attribute wide value.
   --  ------------------------------
   function Get_Unbounded_Wide_Value (Position : in Cursor) return Unbounded_Wide_Wide_String is
      Attr : constant Attribute_Access := Attribute_Vectors.Element (Position.Pos);
   begin
      return To_Unbounded_Wide_Wide_String (Attr.Value);
   end Get_Unbounded_Wide_Value;

   --  ------------------------------
   --  Returns True if the cursor has a valid attribute.
   --  ------------------------------
   function Has_Element (Position : in Cursor) return Boolean is
   begin
      return Attribute_Vectors.Has_Element (Position.Pos);
   end Has_Element;

   --  ------------------------------
   --  Move the cursor to the next attribute.
   --  ------------------------------
   procedure Next (Position : in out Cursor) is
   begin
      Attribute_Vectors.Next (Position.Pos);
   end Next;

   --  ------------------------------
   --  Find the attribute with the given name.
   --  ------------------------------
   function Find (List : in Attribute_List_Type;
                  Name : in String) return Cursor is
      Iter : Attribute_Vectors.Cursor := List.List.First;
   begin
      while Attribute_Vectors.Has_Element (Iter) loop
         declare
            Attr : constant Attribute_Access := Attribute_Vectors.Element (Iter);
         begin
            if Attr.Name = Name then
               return Cursor '(Pos => Iter);
            end if;
         end;
         Attribute_Vectors.Next (Iter);
      end loop;
      return Cursor '(Pos => Iter);
   end Find;

   --  ------------------------------
   --  Find the attribute with the given name and return its value.
   --  ------------------------------
   function Get_Attribute (List : in Attribute_List_Type;
                           Name : in String) return Unbounded_Wide_Wide_String is
      Attr : constant Cursor := Find (List, Name);
   begin
      if Has_Element (Attr) then
         return Get_Unbounded_Wide_Value (Attr);
      else
         return Null_Unbounded_Wide_Wide_String;
      end if;
   end Get_Attribute;

   --  ------------------------------
   --  Append the attribute to the attribute list.
   --  ------------------------------
   procedure Append (List  : in out Attribute_List_Type;
                     Name  : in Wide_Wide_String;
                     Value : in Wide_Wide_String) is
      Attr : constant Attribute_Access
        := new Attribute '(Name_Length  => Name'Length,
                           Value_Length => Value'Length,
                           Name         => Conversions.To_String (Name),
                           Value        => Value);
   begin
      List.List.Append (Attr);
   end Append;

   --  ------------------------------
   --  Append the attribute to the attribute list.
   --  ------------------------------
   procedure Append (List  : in out Attribute_List_Type;
                     Name  : in Ada.Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String;
                     Value : in Ada.Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String) is
   begin
      Append (List, Ada.Strings.Wide_Wide_Unbounded.To_Wide_Wide_String (Name),
              Ada.Strings.Wide_Wide_Unbounded.To_Wide_Wide_String (Value));
   end Append;

   --  ------------------------------
   --  Get the cursor to get access to the first attribute.
   --  ------------------------------
   function First (List : in Attribute_List_Type) return Cursor is
   begin
      return Cursor '(Pos => List.List.First);
   end First;

   --  ------------------------------
   --  Get the number of attributes in the list.
   --  ------------------------------
   function Length (List : in Attribute_List_Type) return Natural is
   begin
      return Natural (List.List.Length);
   end Length;

   --  ------------------------------
   --  Clear the list and remove all existing attributes.
   --  ------------------------------
   procedure Clear (List : in out Attribute_List_Type) is
      procedure Free is
        new Ada.Unchecked_Deallocation (Object => Attribute,
                                        Name   => Attribute_Access);
      Item : Attribute_Access;
   begin
      while not List.List.Is_Empty loop
         Item := List.List.Last_Element;
         List.List.Delete_Last;
         Free (Item);
      end loop;
   end Clear;

   --  ------------------------------
   --  Iterate over the list attributes and call the <tt>Process</tt> procedure.
   --  ------------------------------
   procedure Iterate (List    : in Attribute_List_Type;
                      Process : not null access procedure (Name : in String;
                                                           Value : in Wide_Wide_String)) is
      Iter : Attribute_Vectors.Cursor := List.List.First;
      Item : Attribute_Access;
   begin
      while Attribute_Vectors.Has_Element (Iter) loop
         Item := Attribute_Vectors.Element (Iter);
         Process (Item.Name, Item.Value);
         Attribute_Vectors.Next (Iter);
      end loop;
   end Iterate;

   --  ------------------------------
   --  Finalize the attribute list releasing any storage.
   --  ------------------------------
   overriding
   procedure Finalize (List : in out Attribute_List_Type) is
   begin
      List.Clear;
   end Finalize;

end Wiki.Attributes;

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

package body Wiki.Attributes is

   use Ada.Characters;

   --  ------------------------------
   --  Get the attribute name.
   --  ------------------------------
   function Get_Name (Position : in Cursor) return String is
      Attr : constant Attribute_Access := Attribute_Vectors.Element (Position.Pos);
   begin
      return Attr.Name;
   end Get_Name;

   --  ------------------------------
   --  Get the attribute value.
   --  ------------------------------
   function Get_Value (Position : in Cursor) return String is
      Attr : constant Attribute_Access := Attribute_Vectors.Element (Position.Pos);
   begin
      return Ada.Characters.Conversions.To_String (Attr.Value);
   end Get_Value;

   --  ------------------------------
   --  Get the attribute wide value.
   --  ------------------------------
   function Get_Wide_Value (Position : in Cursor) return Wide_Wide_String is
      Attr : constant Attribute_Access := Attribute_Vectors.Element (Position.Pos);
   begin
      return Attr.Value;
   end Get_Wide_Value;

   --  ------------------------------
   --  Get the attribute wide value.
   --  ------------------------------
   function Get_Unbounded_Wide_Value (Position : in Cursor) return Unbounded_Wide_Wide_String is
      Attr : constant Attribute_Access := Attribute_Vectors.Element (Position.Pos);
   begin
      return To_Unbounded_Wide_Wide_String (Attr.Value);
   end Get_Unbounded_Wide_Value;

   --  ------------------------------
   --  Returns True if the cursor has a valid attribute.
   --  ------------------------------
   function Has_Element (Position : in Cursor) return Boolean is
   begin
      return Attribute_Vectors.Has_Element (Position.Pos);
   end Has_Element;

   --  ------------------------------
   --  Move the cursor to the next attribute.
   --  ------------------------------
   procedure Next (Position : in out Cursor) is
   begin
      Attribute_Vectors.Next (Position.Pos);
   end Next;

   --  ------------------------------
   --  Find the attribute with the given name.
   --  ------------------------------
   function Find (List : in Attribute_List_Type;
                  Name : in String) return Cursor is
      Iter : Attribute_Vectors.Cursor := List.List.First;
   begin
      while Attribute_Vectors.Has_Element (Iter) loop
         declare
            Attr : constant Attribute_Access := Attribute_Vectors.Element (Iter);
         begin
            if Attr.Name = Name then
               return Cursor '(Pos => Iter);
            end if;
         end;
         Attribute_Vectors.Next (Iter);
      end loop;
      return Cursor '(Pos => Iter);
   end Find;

   --  ------------------------------
   --  Find the attribute with the given name and return its value.
   --  ------------------------------
   function Get_Attribute (List : in Attribute_List_Type;
                           Name : in String) return Unbounded_Wide_Wide_String is
      Attr : constant Cursor := Find (List, Name);
   begin
      if Has_Element (Attr) then
         return Get_Unbounded_Wide_Value (Attr);
      else
         return Null_Unbounded_Wide_Wide_String;
      end if;
   end Get_Attribute;

   --  ------------------------------
   --  Append the attribute to the attribute list.
   --  ------------------------------
   procedure Append (List  : in out Attribute_List_Type;
                     Name  : in Wide_Wide_String;
                     Value : in Wide_Wide_String) is
      Attr : constant Attribute_Access
        := new Attribute '(Name_Length  => Name'Length,
                           Value_Length => Value'Length,
                           Name         => Conversions.To_String (Name),
                           Value        => Value);
   begin
      List.List.Append (Attr);
   end Append;

   --  ------------------------------
   --  Append the attribute to the attribute list.
   --  ------------------------------
   procedure Append (List  : in out Attribute_List_Type;
                     Name  : in Ada.Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String;
                     Value : in Ada.Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String) is
   begin
      Append (List, Ada.Strings.Wide_Wide_Unbounded.To_Wide_Wide_String (Name),
              Ada.Strings.Wide_Wide_Unbounded.To_Wide_Wide_String (Value));
   end Append;

   --  ------------------------------
   --  Append the attribute to the attribute list.
   --  ------------------------------
   procedure Append (List  : in out Attribute_List_Type;
                     Name  : in String;
                     Value : in Ada.Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String) is
      Val : constant Wide_Wide_String
        := To_Wide_Wide_String (Value);
      Attr : constant Attribute_Access
        := new Attribute '(Name_Length  => Name'Length,
                           Value_Length => Val'Length,
                           Name         => Name,
                           Value        => Val);
   begin
      List.List.Append (Attr);
   end Append;

   --  ------------------------------
   --  Get the cursor to get access to the first attribute.
   --  ------------------------------
   function First (List : in Attribute_List_Type) return Cursor is
   begin
      return Cursor '(Pos => List.List.First);
   end First;

   --  ------------------------------
   --  Get the number of attributes in the list.
   --  ------------------------------
   function Length (List : in Attribute_List_Type) return Natural is
   begin
      return Natural (List.List.Length);
   end Length;

   --  ------------------------------
   --  Clear the list and remove all existing attributes.
   --  ------------------------------
   procedure Clear (List : in out Attribute_List_Type) is
      procedure Free is
        new Ada.Unchecked_Deallocation (Object => Attribute,
                                        Name   => Attribute_Access);
      Item : Attribute_Access;
   begin
      while not List.List.Is_Empty loop
         Item := List.List.Last_Element;
         List.List.Delete_Last;
         Free (Item);
      end loop;
   end Clear;

   --  ------------------------------
   --  Iterate over the list attributes and call the <tt>Process</tt> procedure.
   --  ------------------------------
   procedure Iterate (List    : in Attribute_List_Type;
                      Process : not null access procedure (Name : in String;
                                                           Value : in Wide_Wide_String)) is
      Iter : Attribute_Vectors.Cursor := List.List.First;
      Item : Attribute_Access;
   begin
      while Attribute_Vectors.Has_Element (Iter) loop
         Item := Attribute_Vectors.Element (Iter);
         Process (Item.Name, Item.Value);
         Attribute_Vectors.Next (Iter);
      end loop;
   end Iterate;

   --  ------------------------------
   --  Finalize the attribute list releasing any storage.
   --  ------------------------------
   overriding
   procedure Finalize (List : in out Attribute_List_Type) is
   begin
      List.Clear;
   end Finalize;

end Wiki.Attributes;

Implement new Append procedure

Implement new Append procedure