-----------------------------------------------------------------------
--  awa-questions-beans -- Beans for module questions
--  Copyright (C) 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 ADO.Queries;
with ADO.Utils;
with ADO.Sessions;
with ADO.Sessions.Entities;

with Util.Beans.Lists.Strings;

with AWA.Tags.Modules;
with AWA.Services.Contexts;
package body AWA.Questions.Beans is

   package ASC renames AWA.Services.Contexts;

   --  ------------------------------
   --  Get the value identified by the name.
   --  ------------------------------
   overriding
   function Get_Value (From : in Question_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "tags" then
         return Util.Beans.Objects.To_Object (From.Tags_Bean, Util.Beans.Objects.STATIC);
      elsif From.Is_Null then
         return Util.Beans.Objects.Null_Object;
      else
         return AWA.Questions.Models.Question_Bean (From).Get_Value (Name);
      end if;
   end Get_Value;

   --  ------------------------------
   --  Set the value identified by the name.
   --  ------------------------------
   overriding
   procedure Set_Value (From  : in out Question_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = "title" then
         From.Set_Title (Util.Beans.Objects.To_String (Value));

      elsif Name = "description" then
         From.Set_Description (Util.Beans.Objects.To_String (Value));

      elsif Name = "id" and not Util.Beans.Objects.Is_Empty (Value) then
         declare
            Ctx : constant ASC.Service_Context_Access := AWA.Services.Contexts.Current;
            DB  : constant ADO.Sessions.Session := AWA.Services.Contexts.Get_Session (Ctx);
            Id  : constant ADO.Identifier := ADO.Utils.To_Identifier (Value);
         begin
            From.Service.Load_Question (From, Id);
            From.Tags.Load_Tags (DB, Id);
         end;
      end if;
   end Set_Value;

   --  ------------------------------
   --  Create or save the question.
   --  ------------------------------
   procedure Save (Bean    : in out Question_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
      pragma Unreferenced (Outcome);
   begin
      Bean.Service.Save_Question (Bean);
      Bean.Tags.Update_Tags (Bean.Get_Id);
   end Save;

   --  ------------------------------
   --  Delete the question.
   --  ------------------------------
   procedure Delete (Bean    : in out Question_Bean;
                     Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
      pragma Unreferenced (Outcome);
   begin
      Bean.Service.Delete_Question (Bean);
   end Delete;

   --  ------------------------------
   --  Create the Question_Bean bean instance.
   --  ------------------------------
   function Create_Question_Bean (Module : in AWA.Questions.Modules.Question_Module_Access)
      return Util.Beans.Basic.Readonly_Bean_Access is
      Object : constant Question_Bean_Access := new Question_Bean;
   begin
      Object.Service   := Module;
      Object.Tags_Bean := Object.Tags'Access;
      Object.Tags.Set_Entity_Type (AWA.Questions.Models.QUESTION_TABLE);
      Object.Tags.Set_Permission ("question-edit");
      return Object.all'Access;
   end Create_Question_Bean;

   --  Get the value identified by the name.
   overriding
   function Get_Value (From : in Answer_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "question_id" then
         return Util.Beans.Objects.To_Object (Long_Long_Integer (From.Question.Get_Id));
      elsif From.Is_Null then
         return Util.Beans.Objects.Null_Object;
      else
         return AWA.Questions.Models.Answer_Bean (From).Get_Value (Name);
      end if;
   end Get_Value;

   --  ------------------------------
   --  Set the value identified by the name.
   --  ------------------------------
   overriding
   procedure Set_Value (From  : in out Answer_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = "id" and not Util.Beans.Objects.Is_Empty (Value) then
         From.Service.Load_Answer (From, From.Question,
                                   ADO.Utils.To_Identifier (Value));

      elsif Name = "answer" then
         From.Set_Answer (Util.Beans.Objects.To_String (Value));

      elsif Name = "question_id" and not Util.Beans.Objects.Is_Null (Value) then
         From.Service.Load_Question (From.Question,
                                     ADO.Utils.To_Identifier (Value));
      end if;
   end Set_Value;

   --  ------------------------------
   --  Create or save the answer.
   --  ------------------------------
   procedure Save (Bean    : in out Answer_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
      pragma Unreferenced (Outcome);
   begin
      Bean.Service.Save_Answer (Question => Bean.Question,
                                Answer   => Bean);
   end Save;

   --  ------------------------------
   --  Delete the question.
   --  ------------------------------
   procedure Delete (Bean    : in out Answer_Bean;
                     Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
      pragma Unreferenced (Outcome);
   begin
      Bean.Service.Delete_Answer (Answer => Bean);
   end Delete;

   --  ------------------------------
   --  Create the answer bean instance.
   --  ------------------------------
   function Create_Answer_Bean (Module : in AWA.Questions.Modules.Question_Module_Access)
                                return Util.Beans.Basic.Readonly_Bean_Access is
      Object : constant Answer_Bean_Access := new Answer_Bean;
   begin
      Object.Service := Module;
      return Object.all'Access;
   end Create_Answer_Bean;

   --  ------------------------------
   --  Get the value identified by the name.
   --  ------------------------------
   overriding
   function Get_Value (From : in Question_List_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
      Pos : Natural;
   begin
      if Name = "tags" then
         Pos := From.Questions.Get_Row_Index;
         if Pos = 0 then
            return Util.Beans.Objects.Null_Object;
         end if;
         declare
            Item : constant Models.Question_Info := From.Questions.List.Element (Pos - 1);
         begin
            return From.Tags.Get_Tags (Item.Id);
         end;
      elsif Name = "questions" then
         return Util.Beans.Objects.To_Object (Value   => From.Questions_Bean,
                                              Storage => Util.Beans.Objects.STATIC);
      else
         return From.Questions.Get_Value (Name);
      end if;
   end Get_Value;

   --  ------------------------------
   --  Set the value identified by the name.
   --  ------------------------------
   overriding
   procedure Set_Value (From  : in out Question_List_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = "tag" then
         From.Tag := Util.Beans.Objects.To_Unbounded_String (Value);
         From.Load_List;
      end if;
   end Set_Value;

   --  ------------------------------
   --  Load the list of question.  If a tag was set, filter the list of questions with the tag.
   --  ------------------------------
   procedure Load_List (Into : in out Question_List_Bean) is
      use AWA.Questions.Models;
      use AWA.Services;
      use type ADO.Identifier;

      Session : ADO.Sessions.Session := Into.Service.Get_Session;
      Query   : ADO.Queries.Context;
      Tag_Id  : ADO.Identifier;
   begin
      AWA.Tags.Modules.Find_Tag_Id (Session, Ada.Strings.Unbounded.To_String (Into.Tag), Tag_Id);
      if Tag_Id /= ADO.NO_IDENTIFIER then
         Query.Set_Query (AWA.Questions.Models.Query_Question_Tag_List);
         Query.Bind_Param (Name => "tag", Value => Tag_Id);
      else
         Query.Set_Query (AWA.Questions.Models.Query_Question_List);
      end if;
      ADO.Sessions.Entities.Bind_Param (Params  => Query,
                                        Name    => "entity_type",
                                        Table   => AWA.Questions.Models.QUESTION_TABLE,
                                        Session => Session);
      AWA.Questions.Models.List (Into.Questions, Session, Query);
      declare
         List : ADO.Utils.Identifier_Vector;
         Iter : Question_Info_Vectors.Cursor := Into.Questions.List.First;
      begin
         while Question_Info_Vectors.Has_Element (Iter) loop
            List.Append (Question_Info_Vectors.Element (Iter).Id);
            Question_Info_Vectors.Next (Iter);
         end loop;
         Into.Tags.Load_Tags (Session, AWA.Questions.Models.QUESTION_TABLE.Table.all,
                              List);
      end;
   end Load_List;

   --  ------------------------------
   --  Create the Question_Info_List_Bean bean instance.
   --  ------------------------------
   function Create_Question_List_Bean (Module : in AWA.Questions.Modules.Question_Module_Access)
                                       return Util.Beans.Basic.Readonly_Bean_Access is
      use AWA.Questions.Models;
      use AWA.Services;

      Object  : constant Question_List_Bean_Access := new Question_List_Bean;
--        Session : ADO.Sessions.Session := Module.Get_Session;
--        Query   : ADO.Queries.Context;
   begin
      Object.Service := Module;
      Object.Questions_Bean := Object.Questions'Unchecked_Access;
--        Query.Set_Query (AWA.Questions.Models.Query_Question_List);
--        ADO.Sessions.Entities.Bind_Param (Params  => Query,
--                                          Name    => "entity_type",
--                                          Table   => AWA.Questions.Models.QUESTION_TABLE,
--                                          Session => Session);
--        AWA.Questions.Models.List (Object.Questions, Session, Query);
      Object.Load_List;
      return Object.all'Access;
   end Create_Question_List_Bean;

   --  ------------------------------
   --  Get the value identified by the name.
   --  ------------------------------
   overriding
   function Get_Value (From : in Question_Display_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "answers" then
         return Util.Beans.Objects.To_Object (Value   => From.Answer_List_Bean,
                                              Storage => Util.Beans.Objects.STATIC);

      elsif Name = "question" then
         return Util.Beans.Objects.To_Object (Value   => From.Question_Bean,
                                              Storage => Util.Beans.Objects.STATIC);

      elsif Name = "tags" then
         return Util.Beans.Objects.To_Object (Value   => From.Tags_Bean,
                                              Storage => Util.Beans.Objects.STATIC);

      else
         return Util.Beans.Objects.Null_Object;
      end if;
   end Get_Value;

   --  ------------------------------
   --  Set the value identified by the name.
   --  ------------------------------
   overriding
   procedure Set_Value (From  : in out Question_Display_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = "id" and not Util.Beans.Objects.Is_Empty (Value) then
         declare
            package ASC renames AWA.Services.Contexts;
            use AWA.Questions.Models;
            use AWA.Services;

            Session : ADO.Sessions.Session := From.Service.Get_Session;
            Query   : ADO.Queries.Context;
            List    : AWA.Questions.Models.Question_Display_Info_List_Bean;
            Ctx     : constant ASC.Service_Context_Access := ASC.Current;
            Id      : constant ADO.Identifier := ADO.Utils.To_Identifier (Value);
         begin
            Query.Set_Query (AWA.Questions.Models.Query_Question_Info);
            Query.Bind_Param ("question_id", Id);
            Query.Bind_Param ("user_id", Ctx.Get_User_Identifier);
            ADO.Sessions.Entities.Bind_Param (Params  => Query,
                                              Name    => "entity_type",
                                              Table   => AWA.Questions.Models.QUESTION_TABLE,
                                              Session => Session);
            AWA.Questions.Models.List (List, Session, Query);
            if not List.List.Is_Empty then
               From.Question := List.List.Element (0);
            end if;
            Query.Clear;
            Query.Bind_Param ("question_id", Util.Beans.Objects.To_Integer (Value));
            Query.Bind_Param ("user_id", Ctx.Get_User_Identifier);
            ADO.Sessions.Entities.Bind_Param (Params  => Query,
                                              Name    => "entity_type",
                                              Table   => AWA.Questions.Models.ANSWER_TABLE,
                                              Session => Session);

            Query.Set_Query (AWA.Questions.Models.Query_Answer_List);
            AWA.Questions.Models.List (From.Answer_List, Session, Query);

            --  Load the tags if any.
            From.Tags.Load_Tags (Session, Id);
         end;
      end if;
   end Set_Value;

   --  ------------------------------
   --  Create the Question_Display_Bean bean instance.
   --  ------------------------------
   function Create_Question_Display_Bean (Module : in AWA.Questions.Modules.Question_Module_Access)
                                       return Util.Beans.Basic.Readonly_Bean_Access is
      Object  : constant Question_Display_Bean_Access := new Question_Display_Bean;
   begin
      Object.Service          := Module;
      Object.Question_Bean    := Object.Question'Access;
      Object.Answer_List_Bean := Object.Answer_List'Access;
      Object.Tags_Bean        := Object.Tags'Access;
      Object.Tags.Set_Entity_Type (AWA.Questions.Models.QUESTION_TABLE);
      return Object.all'Access;
   end Create_Question_Display_Bean;

end AWA.Questions.Beans;

-----------------------------------------------------------------------
--  awa-questions-beans -- Beans for module questions
--  Copyright (C) 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 ADO.Queries;
with ADO.Utils;
with ADO.Sessions;
with ADO.Sessions.Entities;

with Util.Beans.Lists.Strings;

with AWA.Tags.Modules;
with AWA.Services.Contexts;
package body AWA.Questions.Beans is

   package ASC renames AWA.Services.Contexts;

   --  ------------------------------
   --  Get the value identified by the name.
   --  ------------------------------
   overriding
   function Get_Value (From : in Question_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "tags" then
         return Util.Beans.Objects.To_Object (From.Tags_Bean, Util.Beans.Objects.STATIC);
      elsif From.Is_Null then
         return Util.Beans.Objects.Null_Object;
      else
         return AWA.Questions.Models.Question_Bean (From).Get_Value (Name);
      end if;
   end Get_Value;

   --  ------------------------------
   --  Set the value identified by the name.
   --  ------------------------------
   overriding
   procedure Set_Value (From  : in out Question_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = "title" then
         From.Set_Title (Util.Beans.Objects.To_String (Value));

      elsif Name = "description" then
         From.Set_Description (Util.Beans.Objects.To_String (Value));

      elsif Name = "id" and not Util.Beans.Objects.Is_Empty (Value) then
         declare
            Ctx : constant ASC.Service_Context_Access := AWA.Services.Contexts.Current;
            DB  : constant ADO.Sessions.Session := AWA.Services.Contexts.Get_Session (Ctx);
            Id  : constant ADO.Identifier := ADO.Utils.To_Identifier (Value);
         begin
            From.Service.Load_Question (From, Id);
            From.Tags.Load_Tags (DB, Id);
         end;
      end if;
   end Set_Value;

   --  ------------------------------
   --  Create or save the question.
   --  ------------------------------
   procedure Save (Bean    : in out Question_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
      pragma Unreferenced (Outcome);
   begin
      Bean.Service.Save_Question (Bean);
      Bean.Tags.Update_Tags (Bean.Get_Id);
   end Save;

   --  ------------------------------
   --  Delete the question.
   --  ------------------------------
   procedure Delete (Bean    : in out Question_Bean;
                     Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
      pragma Unreferenced (Outcome);
   begin
      Bean.Service.Delete_Question (Bean);
   end Delete;

   --  ------------------------------
   --  Create the Question_Bean bean instance.
   --  ------------------------------
   function Create_Question_Bean (Module : in AWA.Questions.Modules.Question_Module_Access)
      return Util.Beans.Basic.Readonly_Bean_Access is
      Object : constant Question_Bean_Access := new Question_Bean;
   begin
      Object.Service   := Module;
      Object.Tags_Bean := Object.Tags'Access;
      Object.Tags.Set_Entity_Type (AWA.Questions.Models.QUESTION_TABLE);
      Object.Tags.Set_Permission ("question-edit");
      return Object.all'Access;
   end Create_Question_Bean;

   --  Get the value identified by the name.
   overriding
   function Get_Value (From : in Answer_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "question_id" then
         return Util.Beans.Objects.To_Object (Long_Long_Integer (From.Question.Get_Id));
      elsif From.Is_Null then
         return Util.Beans.Objects.Null_Object;
      else
         return AWA.Questions.Models.Answer_Bean (From).Get_Value (Name);
      end if;
   end Get_Value;

   --  ------------------------------
   --  Set the value identified by the name.
   --  ------------------------------
   overriding
   procedure Set_Value (From  : in out Answer_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = "id" and not Util.Beans.Objects.Is_Empty (Value) then
         From.Service.Load_Answer (From, From.Question,
                                   ADO.Utils.To_Identifier (Value));

      elsif Name = "answer" then
         From.Set_Answer (Util.Beans.Objects.To_String (Value));

      elsif Name = "question_id" and not Util.Beans.Objects.Is_Null (Value) then
         From.Service.Load_Question (From.Question,
                                     ADO.Utils.To_Identifier (Value));
      end if;
   end Set_Value;

   --  ------------------------------
   --  Create or save the answer.
   --  ------------------------------
   procedure Save (Bean    : in out Answer_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
      pragma Unreferenced (Outcome);
   begin
      Bean.Service.Save_Answer (Question => Bean.Question,
                                Answer   => Bean);
   end Save;

   --  ------------------------------
   --  Delete the question.
   --  ------------------------------
   procedure Delete (Bean    : in out Answer_Bean;
                     Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
      pragma Unreferenced (Outcome);
   begin
      Bean.Service.Delete_Answer (Answer => Bean);
   end Delete;

   --  ------------------------------
   --  Create the answer bean instance.
   --  ------------------------------
   function Create_Answer_Bean (Module : in AWA.Questions.Modules.Question_Module_Access)
                                return Util.Beans.Basic.Readonly_Bean_Access is
      Object : constant Answer_Bean_Access := new Answer_Bean;
   begin
      Object.Service := Module;
      return Object.all'Access;
   end Create_Answer_Bean;

   --  ------------------------------
   --  Get the value identified by the name.
   --  ------------------------------
   overriding
   function Get_Value (From : in Question_List_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
      Pos : Natural;
   begin
      if Name = "tags" then
         Pos := From.Questions.Get_Row_Index;
         if Pos = 0 then
            return Util.Beans.Objects.Null_Object;
         end if;
         declare
            Item : constant Models.Question_Info := From.Questions.List.Element (Pos - 1);
         begin
            return From.Tags.Get_Tags (Item.Id);
         end;
      elsif Name = "questions" then
         return Util.Beans.Objects.To_Object (Value   => From.Questions_Bean,
                                              Storage => Util.Beans.Objects.STATIC);
      elsif Name = "tag" then
         return Util.Beans.Objects.To_Object (From.Tag);
      else
         return From.Questions.Get_Value (Name);
      end if;
   end Get_Value;

   --  ------------------------------
   --  Set the value identified by the name.
   --  ------------------------------
   overriding
   procedure Set_Value (From  : in out Question_List_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = "tag" then
         From.Tag := Util.Beans.Objects.To_Unbounded_String (Value);
         From.Load_List;
      end if;
   end Set_Value;

   --  ------------------------------
   --  Load the list of question.  If a tag was set, filter the list of questions with the tag.
   --  ------------------------------
   procedure Load_List (Into : in out Question_List_Bean) is
      use AWA.Questions.Models;
      use AWA.Services;
      use type ADO.Identifier;

      Session : ADO.Sessions.Session := Into.Service.Get_Session;
      Query   : ADO.Queries.Context;
      Tag_Id  : ADO.Identifier;
   begin
      AWA.Tags.Modules.Find_Tag_Id (Session, Ada.Strings.Unbounded.To_String (Into.Tag), Tag_Id);
      if Tag_Id /= ADO.NO_IDENTIFIER then
         Query.Set_Query (AWA.Questions.Models.Query_Question_Tag_List);
         Query.Bind_Param (Name => "tag", Value => Tag_Id);
      else
         Query.Set_Query (AWA.Questions.Models.Query_Question_List);
      end if;
      ADO.Sessions.Entities.Bind_Param (Params  => Query,
                                        Name    => "entity_type",
                                        Table   => AWA.Questions.Models.QUESTION_TABLE,
                                        Session => Session);
      AWA.Questions.Models.List (Into.Questions, Session, Query);
      declare
         List : ADO.Utils.Identifier_Vector;
         Iter : Question_Info_Vectors.Cursor := Into.Questions.List.First;
      begin
         while Question_Info_Vectors.Has_Element (Iter) loop
            List.Append (Question_Info_Vectors.Element (Iter).Id);
            Question_Info_Vectors.Next (Iter);
         end loop;
         Into.Tags.Load_Tags (Session, AWA.Questions.Models.QUESTION_TABLE.Table.all,
                              List);
      end;
   end Load_List;

   --  ------------------------------
   --  Create the Question_Info_List_Bean bean instance.
   --  ------------------------------
   function Create_Question_List_Bean (Module : in AWA.Questions.Modules.Question_Module_Access)
                                       return Util.Beans.Basic.Readonly_Bean_Access is
      use AWA.Questions.Models;
      use AWA.Services;

      Object  : constant Question_List_Bean_Access := new Question_List_Bean;
--        Session : ADO.Sessions.Session := Module.Get_Session;
--        Query   : ADO.Queries.Context;
   begin
      Object.Service := Module;
      Object.Questions_Bean := Object.Questions'Unchecked_Access;
--        Query.Set_Query (AWA.Questions.Models.Query_Question_List);
--        ADO.Sessions.Entities.Bind_Param (Params  => Query,
--                                          Name    => "entity_type",
--                                          Table   => AWA.Questions.Models.QUESTION_TABLE,
--                                          Session => Session);
--        AWA.Questions.Models.List (Object.Questions, Session, Query);
      Object.Load_List;
      return Object.all'Access;
   end Create_Question_List_Bean;

   --  ------------------------------
   --  Get the value identified by the name.
   --  ------------------------------
   overriding
   function Get_Value (From : in Question_Display_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "answers" then
         return Util.Beans.Objects.To_Object (Value   => From.Answer_List_Bean,
                                              Storage => Util.Beans.Objects.STATIC);

      elsif Name = "question" then
         return Util.Beans.Objects.To_Object (Value   => From.Question_Bean,
                                              Storage => Util.Beans.Objects.STATIC);

      elsif Name = "tags" then
         return Util.Beans.Objects.To_Object (Value   => From.Tags_Bean,
                                              Storage => Util.Beans.Objects.STATIC);

      else
         return Util.Beans.Objects.Null_Object;
      end if;
   end Get_Value;

   --  ------------------------------
   --  Set the value identified by the name.
   --  ------------------------------
   overriding
   procedure Set_Value (From  : in out Question_Display_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = "id" and not Util.Beans.Objects.Is_Empty (Value) then
         declare
            package ASC renames AWA.Services.Contexts;
            use AWA.Questions.Models;
            use AWA.Services;

            Session : ADO.Sessions.Session := From.Service.Get_Session;
            Query   : ADO.Queries.Context;
            List    : AWA.Questions.Models.Question_Display_Info_List_Bean;
            Ctx     : constant ASC.Service_Context_Access := ASC.Current;
            Id      : constant ADO.Identifier := ADO.Utils.To_Identifier (Value);
         begin
            Query.Set_Query (AWA.Questions.Models.Query_Question_Info);
            Query.Bind_Param ("question_id", Id);
            Query.Bind_Param ("user_id", Ctx.Get_User_Identifier);
            ADO.Sessions.Entities.Bind_Param (Params  => Query,
                                              Name    => "entity_type",
                                              Table   => AWA.Questions.Models.QUESTION_TABLE,
                                              Session => Session);
            AWA.Questions.Models.List (List, Session, Query);
            if not List.List.Is_Empty then
               From.Question := List.List.Element (0);
            end if;
            Query.Clear;
            Query.Bind_Param ("question_id", Util.Beans.Objects.To_Integer (Value));
            Query.Bind_Param ("user_id", Ctx.Get_User_Identifier);
            ADO.Sessions.Entities.Bind_Param (Params  => Query,
                                              Name    => "entity_type",
                                              Table   => AWA.Questions.Models.ANSWER_TABLE,
                                              Session => Session);

            Query.Set_Query (AWA.Questions.Models.Query_Answer_List);
            AWA.Questions.Models.List (From.Answer_List, Session, Query);

            --  Load the tags if any.
            From.Tags.Load_Tags (Session, Id);
         end;
      end if;
   end Set_Value;

   --  ------------------------------
   --  Create the Question_Display_Bean bean instance.
   --  ------------------------------
   function Create_Question_Display_Bean (Module : in AWA.Questions.Modules.Question_Module_Access)
                                       return Util.Beans.Basic.Readonly_Bean_Access is
      Object  : constant Question_Display_Bean_Access := new Question_Display_Bean;
   begin
      Object.Service          := Module;
      Object.Question_Bean    := Object.Question'Access;
      Object.Answer_List_Bean := Object.Answer_List'Access;
      Object.Tags_Bean        := Object.Tags'Access;
      Object.Tags.Set_Entity_Type (AWA.Questions.Models.QUESTION_TABLE);
      return Object.all'Access;
   end Create_Question_Display_Bean;

end AWA.Questions.Beans;

Make the current tag value visible to the question list bean


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

package body Mapping is

   use Util.Beans.Objects;

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Mapping");

   procedure Rest_Get (URI     : in String;
		       Mapping : in Util.Serialize.Mappers.Mapper_Access;
		       Into    : in Element_Type_Access) is
      Http     : Util.Http.Clients.Client;
      Reader   : Util.Serialize.IO.JSON.Parser;
      Response : Util.Http.Clients.Response;
   begin
      Reader.Add_Mapping ("", Mapping);
      Set_Context (Reader, Into);
      Http.Get (URI, Response);
      declare
	 Content : constant String := Response.Get_Body;
      begin
	 Reader.Parse_String (Content);
      end;
   end Rest_Get;

   type Property_Fields is (FIELD_NAME, FIELD_VALUE);
   type Property_Access is access all Property;

   type Address_Fields is (FIELD_CITY, FIELD_STREET, FIELD_COUNTRY, FIELD_ZIP);
   type Address_Access is access all Address;

   procedure Proxy_Address (Attr    : in Util.Serialize.Mappers.Mapping'Class;
                            Element : in out Person;
                            Value   : in Util.Beans.Objects.Object);
   function Get_Address_Member (Addr  : in Address;
                                Field : in Address_Fields) return Util.Beans.Objects.Object;
   procedure Set_Member (Addr  : in out Address;
                         Field : in Address_Fields;
                         Value : in Util.Beans.Objects.Object);
   procedure Set_Member (P : in out Property;
                         Field : in Property_Fields;
                         Value : in Util.Beans.Objects.Object);

   procedure Set_Member (P : in out Property;
                         Field : in Property_Fields;
                         Value : in Util.Beans.Objects.Object) is
   begin
      case Field is
         when FIELD_NAME =>
            P.Name := To_Unbounded_String (Value);

         when FIELD_VALUE =>
            P.Value := To_Unbounded_String (Value);

      end case;
   end Set_Member;

   package Property_Mapper is
     new Util.Serialize.Mappers.Record_Mapper (Element_Type        => Property,
                                               Element_Type_Access => Property_Access,
                                               Fields              => Property_Fields,
                                               Set_Member          => Set_Member);

   --  ------------------------------
   --  Set the name/value pair on the current object.
   --  ------------------------------
   procedure Set_Member (P     : in out Person;
                         Field : in Person_Fields;
                         Value : in Util.Beans.Objects.Object) is
   begin
      Log.Debug ("Person field {0} - {0}", Person_Fields'Image (Field), To_String (Value));
      case Field is
         when FIELD_FIRST_NAME =>
            P.First_Name := To_Unbounded_String (Value);

         when FIELD_LAST_NAME =>
            P.Last_Name := To_Unbounded_String (Value);

         when FIELD_AGE =>
            P.Age := To_Integer (Value);

         when FIELD_ID =>
            P.Id := To_Long_Long_Integer (Value);

         when FIELD_NAME =>
            P.Name := To_Unbounded_String (Value);

         when FIELD_USER_NAME =>
            P.Username := To_Unbounded_String (Value);

         when FIELD_GENDER =>
            P.Gender := To_Unbounded_String (Value);

         when FIELD_LINK =>
            P.Link := To_Unbounded_String (Value);

      end case;
   end Set_Member;

   --  ------------------------------
   --  Set the name/value pair on the current object.
   --  ------------------------------
   function Get_Person_Member (From  : in Person;
                               Field : in Person_Fields) return Util.Beans.Objects.Object is
   begin
      case Field is
         when FIELD_FIRST_NAME =>
            return Util.Beans.Objects.To_Object (From.First_Name);

         when FIELD_LAST_NAME =>
            return Util.Beans.Objects.To_Object (From.Last_Name);

         when FIELD_AGE =>
            return Util.Beans.Objects.To_Object (From.Age);

         when FIELD_NAME =>
            return Util.Beans.Objects.To_Object (From.Name);

         when FIELD_USER_NAME =>
            return Util.Beans.Objects.To_Object (From.Username);

         when FIELD_LINK =>
            return Util.Beans.Objects.To_Object (From.Link);

         when FIELD_GENDER =>
            return Util.Beans.Objects.To_Object (From.Gender);

         when FIELD_ID =>
            return Util.Beans.Objects.To_Object (From.Id);

      end case;
   end Get_Person_Member;

   --  ------------------------------
   --  Set the name/value pair on the current object.
   --  ------------------------------
   procedure Set_Member (Addr  : in out Address;
                         Field : in Address_Fields;
                         Value : in Util.Beans.Objects.Object) is
   begin
      case Field is
         when FIELD_CITY =>
            Addr.City := To_Unbounded_String (Value);

         when FIELD_STREET =>
            Addr.Street := To_Unbounded_String (Value);

         when FIELD_COUNTRY =>
            Addr.Country := To_Unbounded_String (Value);

         when FIELD_ZIP =>
            Addr.Zip := To_Integer (Value);

      end case;
   end Set_Member;

   function Get_Address_Member (Addr  : in Address;
                                Field : in Address_Fields) return Util.Beans.Objects.Object is
   begin
      case Field is
         when FIELD_CITY =>
            return Util.Beans.Objects.To_Object (Addr.City);

         when FIELD_STREET =>
            return Util.Beans.Objects.To_Object (Addr.Street);

         when FIELD_COUNTRY =>
            return Util.Beans.Objects.To_Object (Addr.Country);

         when FIELD_ZIP =>
            return Util.Beans.Objects.To_Object (Addr.Zip);

      end case;
   end Get_Address_Member;

   package Address_Mapper is
     new Util.Serialize.Mappers.Record_Mapper (Element_Type        => Address,
                                               Element_Type_Access => Address_Access,
                                               Fields              => Address_Fields,
                                               Set_Member          => Set_Member);

   --  Mapping for the Property record.
   Property_Mapping      : aliased Property_Mapper.Mapper;

   --  Mapping for the Address record.
   Address_Mapping       : aliased Address_Mapper.Mapper;

   --  Mapping for the Person record.
   Person_Mapping        : aliased Person_Mapper.Mapper;

   --  Mapping for a list of Person records (stored as a Vector).
   Person_Vector_Mapping : aliased Person_Vector_Mapper.Mapper;

   --  ------------------------------
   --  Get the address mapper which describes how to load an Address.
   --  ------------------------------
   function Get_Address_Mapper return Util.Serialize.Mappers.Mapper_Access is
   begin
      return Address_Mapping'Access;
   end Get_Address_Mapper;

   --  ------------------------------
   --  Get the person mapper which describes how to load a Person.
   --  ------------------------------
   function Get_Person_Mapper return Person_Mapper.Mapper_Access is
   begin
      return Person_Mapping'Access;
   end Get_Person_Mapper;

   --  ------------------------------
   --  Get the person vector mapper which describes how to load a list of Person.
   --  ------------------------------
   function Get_Person_Vector_Mapper return Person_Vector_Mapper.Mapper_Access is
   begin
      return Person_Vector_Mapping'Access;
   end Get_Person_Vector_Mapper;

   --  ------------------------------
   --  Helper to give access to the Address member of a Person.
   --  ------------------------------
   procedure Proxy_Address (Attr    : in Util.Serialize.Mappers.Mapping'Class;
                            Element : in out Person;
                            Value   : in Util.Beans.Objects.Object) is
   begin
      Address_Mapper.Set_Member (Attr, Element.Addr, Value);
   end Proxy_Address;

begin
   Property_Mapping.Add_Default_Mapping;

   --  XML:                                JSON:
   --  ----                                -----
   --  <city>Paris</city>                  "city" : "Paris"
   --  <street>Champs de Mars</street>     "street" : "Champs de Mars"
   --  <country>France</country>           "country" : "France"
   --  <zip>75</zip>                       "zip" : 75
   Address_Mapping.Bind (Get_Address_Member'Access);
--     Address_Mapping.Add_Mapping ("info", Property_Mapping'Access, Proxy_Info'Access);
   Address_Mapping.Add_Default_Mapping;

   --  XML:
   --  ----
   --  <xxx id='23'>
   --     <address>
   --        <city>...</city>
   --        <street number='44'>..</street>
   --        <country>..</country>
   --        <zip>..</zip>
   --     </address>
   --     <name>John</name>
   --     <last_name>Harry</last_name>
   --     <age>23</age>
   --     <info><facebook><id>...</id></facebook></info>
   --  </xxx>
   --  Person_Mapper.Add_Mapping ("@id");
   Person_Mapping.Bind (Get_Person_Member'Access);
   Person_Mapping.Add_Mapping ("address", Address_Mapping'Access, Proxy_Address'Access);
   Person_Mapping.Add_Default_Mapping;
   --  Person_Mapper.Add_Mapping ("info/*");
   --  Person_Mapper.Add_Mapping ("address/street/@number");

   Person_Vector_Mapping.Set_Mapping (Person_Mapping'Access);
end Mapping;

-----------------------------------------------------------------------
--  mapping -- Example of serialization mappings
--  Copyright (C) 2010, 2011, 2012 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Util.Log.Loggers;
with Util.Http.Clients;
with Util.Http.Clients.Web;
with Util.Serialize.IO.JSON;
with Util.Http.Rest;
package body Mapping is

   use Util.Beans.Objects;

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Mapping");

   procedure Rest_Get (URI     : in String;
                       Mapping : in Util.Serialize.Mappers.Mapper_Access;
                       Into    : in Element_Type_Access) is
      Http     : Util.Http.Rest.Client;
      Reader   : Util.Serialize.IO.JSON.Parser;
   begin
      Reader.Add_Mapping ("", Mapping);
      Set_Context (Reader, Into);
      Http.Get (URI, Reader);
   end Rest_Get;

   type Property_Fields is (FIELD_NAME, FIELD_VALUE);
   type Property_Access is access all Property;

   type Address_Fields is (FIELD_CITY, FIELD_STREET, FIELD_COUNTRY, FIELD_ZIP);
   type Address_Access is access all Address;

   procedure Proxy_Address (Attr    : in Util.Serialize.Mappers.Mapping'Class;
                            Element : in out Person;
                            Value   : in Util.Beans.Objects.Object);
   function Get_Address_Member (Addr  : in Address;
                                Field : in Address_Fields) return Util.Beans.Objects.Object;
   procedure Set_Member (Addr  : in out Address;
                         Field : in Address_Fields;
                         Value : in Util.Beans.Objects.Object);
   procedure Set_Member (P : in out Property;
                         Field : in Property_Fields;
                         Value : in Util.Beans.Objects.Object);

   procedure Set_Member (P : in out Property;
                         Field : in Property_Fields;
                         Value : in Util.Beans.Objects.Object) is
   begin
      case Field is
         when FIELD_NAME =>
            P.Name := To_Unbounded_String (Value);

         when FIELD_VALUE =>
            P.Value := To_Unbounded_String (Value);

      end case;
   end Set_Member;

   package Property_Mapper is
     new Util.Serialize.Mappers.Record_Mapper (Element_Type        => Property,
                                               Element_Type_Access => Property_Access,
                                               Fields              => Property_Fields,
                                               Set_Member          => Set_Member);

   --  ------------------------------
   --  Set the name/value pair on the current object.
   --  ------------------------------
   procedure Set_Member (P     : in out Person;
                         Field : in Person_Fields;
                         Value : in Util.Beans.Objects.Object) is
   begin
      Log.Debug ("Person field {0} - {0}", Person_Fields'Image (Field), To_String (Value));
      case Field is
         when FIELD_FIRST_NAME =>
            P.First_Name := To_Unbounded_String (Value);

         when FIELD_LAST_NAME =>
            P.Last_Name := To_Unbounded_String (Value);

         when FIELD_AGE =>
            P.Age := To_Integer (Value);

         when FIELD_ID =>
            P.Id := To_Long_Long_Integer (Value);

         when FIELD_NAME =>
            P.Name := To_Unbounded_String (Value);

         when FIELD_USER_NAME =>
            P.Username := To_Unbounded_String (Value);

         when FIELD_GENDER =>
            P.Gender := To_Unbounded_String (Value);

         when FIELD_LINK =>
            P.Link := To_Unbounded_String (Value);

      end case;
   end Set_Member;

   --  ------------------------------
   --  Set the name/value pair on the current object.
   --  ------------------------------
   function Get_Person_Member (From  : in Person;
                               Field : in Person_Fields) return Util.Beans.Objects.Object is
   begin
      case Field is
         when FIELD_FIRST_NAME =>
            return Util.Beans.Objects.To_Object (From.First_Name);

         when FIELD_LAST_NAME =>
            return Util.Beans.Objects.To_Object (From.Last_Name);

         when FIELD_AGE =>
            return Util.Beans.Objects.To_Object (From.Age);

         when FIELD_NAME =>
            return Util.Beans.Objects.To_Object (From.Name);

         when FIELD_USER_NAME =>
            return Util.Beans.Objects.To_Object (From.Username);

         when FIELD_LINK =>
            return Util.Beans.Objects.To_Object (From.Link);

         when FIELD_GENDER =>
            return Util.Beans.Objects.To_Object (From.Gender);

         when FIELD_ID =>
            return Util.Beans.Objects.To_Object (From.Id);

      end case;
   end Get_Person_Member;

   --  ------------------------------
   --  Set the name/value pair on the current object.
   --  ------------------------------
   procedure Set_Member (Addr  : in out Address;
                         Field : in Address_Fields;
                         Value : in Util.Beans.Objects.Object) is
   begin
      case Field is
         when FIELD_CITY =>
            Addr.City := To_Unbounded_String (Value);

         when FIELD_STREET =>
            Addr.Street := To_Unbounded_String (Value);

         when FIELD_COUNTRY =>
            Addr.Country := To_Unbounded_String (Value);

         when FIELD_ZIP =>
            Addr.Zip := To_Integer (Value);

      end case;
   end Set_Member;

   function Get_Address_Member (Addr  : in Address;
                                Field : in Address_Fields) return Util.Beans.Objects.Object is
   begin
      case Field is
         when FIELD_CITY =>
            return Util.Beans.Objects.To_Object (Addr.City);

         when FIELD_STREET =>
            return Util.Beans.Objects.To_Object (Addr.Street);

         when FIELD_COUNTRY =>
            return Util.Beans.Objects.To_Object (Addr.Country);

         when FIELD_ZIP =>
            return Util.Beans.Objects.To_Object (Addr.Zip);

      end case;
   end Get_Address_Member;

   package Address_Mapper is
     new Util.Serialize.Mappers.Record_Mapper (Element_Type        => Address,
                                               Element_Type_Access => Address_Access,
                                               Fields              => Address_Fields,
                                               Set_Member          => Set_Member);

   --  Mapping for the Property record.
   Property_Mapping      : aliased Property_Mapper.Mapper;

   --  Mapping for the Address record.
   Address_Mapping       : aliased Address_Mapper.Mapper;

   --  Mapping for the Person record.
   Person_Mapping        : aliased Person_Mapper.Mapper;

   --  Mapping for a list of Person records (stored as a Vector).
   Person_Vector_Mapping : aliased Person_Vector_Mapper.Mapper;

   --  ------------------------------
   --  Get the address mapper which describes how to load an Address.
   --  ------------------------------
   function Get_Address_Mapper return Util.Serialize.Mappers.Mapper_Access is
   begin
      return Address_Mapping'Access;
   end Get_Address_Mapper;

   --  ------------------------------
   --  Get the person mapper which describes how to load a Person.
   --  ------------------------------
   function Get_Person_Mapper return Person_Mapper.Mapper_Access is
   begin
      return Person_Mapping'Access;
   end Get_Person_Mapper;

   --  ------------------------------
   --  Get the person vector mapper which describes how to load a list of Person.
   --  ------------------------------
   function Get_Person_Vector_Mapper return Person_Vector_Mapper.Mapper_Access is
   begin
      return Person_Vector_Mapping'Access;
   end Get_Person_Vector_Mapper;

   --  ------------------------------
   --  Helper to give access to the Address member of a Person.
   --  ------------------------------
   procedure Proxy_Address (Attr    : in Util.Serialize.Mappers.Mapping'Class;
                            Element : in out Person;
                            Value   : in Util.Beans.Objects.Object) is
   begin
      Address_Mapper.Set_Member (Attr, Element.Addr, Value);
   end Proxy_Address;

begin
   Property_Mapping.Add_Default_Mapping;

   --  XML:                                JSON:
   --  ----                                -----
   --  <city>Paris</city>                  "city" : "Paris"
   --  <street>Champs de Mars</street>     "street" : "Champs de Mars"
   --  <country>France</country>           "country" : "France"
   --  <zip>75</zip>                       "zip" : 75
   Address_Mapping.Bind (Get_Address_Member'Access);
--     Address_Mapping.Add_Mapping ("info", Property_Mapping'Access, Proxy_Info'Access);
   Address_Mapping.Add_Default_Mapping;

   --  XML:
   --  ----
   --  <xxx id='23'>
   --     <address>
   --        <city>...</city>
   --        <street number='44'>..</street>
   --        <country>..</country>
   --        <zip>..</zip>
   --     </address>
   --     <name>John</name>
   --     <last_name>Harry</last_name>
   --     <age>23</age>
   --     <info><facebook><id>...</id></facebook></info>
   --  </xxx>
   --  Person_Mapper.Add_Mapping ("@id");
   Person_Mapping.Bind (Get_Person_Member'Access);
   Person_Mapping.Add_Mapping ("address", Address_Mapping'Access, Proxy_Address'Access);
   Person_Mapping.Add_Default_Mapping;
   --  Person_Mapper.Add_Mapping ("info/*");
   --  Person_Mapper.Add_Mapping ("address/street/@number");

   Person_Vector_Mapping.Set_Mapping (Person_Mapping'Access);
end Mapping;

Use the new REST support to implement the generic rest Get operation


--  This file is covered by the Internet Software Consortium (ISC) License
--  Reference: ../License.txt

with Parameters;
with HelperText;
with Unix;
with File_Operations;
with Ada.Directories;
with Ada.Text_IO;

package body Ravenports is

   package PM  renames Parameters;
   package HT  renames HelperText;
   package FOP renames File_Operations;
   package TIO renames Ada.Text_IO;
   package DIR renames Ada.Directories;

   --------------------------------------------------------------------------------------------
   --  check_version_available
   --------------------------------------------------------------------------------------------
   procedure check_version_available
   is
      consdir       : constant String := HT.USS (PM.configuration.dir_conspiracy);
      version_loc   : constant String := consdir & conspiracy_version;
   begin
      if DIR.Exists (version_loc) then
         if fetch_latest_version_info (temporary_ver_loc) then
            declare
               currentver : constant String := FOP.head_n1 (version_loc);
               latestver  : constant String := FOP.head_n1 (temporary_ver_loc);
            begin
               if latestver = currentver then
                  TIO.Put_Line ("The latest version of Ravenports, " & latestver &
                                  ", is currently installed.");
               else
                  TIO.Put_Line ("A newer version of Ravenports is available: " & latestver);
                  TIO.Put_Line ("The " & currentver & " version is currently installed.");
               end if;
            end;
            DIR.Delete_File (temporary_ver_loc);
         end if;
      else
         TIO.Put_Line ("It appears that Ravenports has not been installed at " & consdir);
      end if;
   exception
      when others => null;
   end check_version_available;

   --------------------------------------------------------------------------------------------
   --  fetch_latest_version_info
   --------------------------------------------------------------------------------------------
   function fetch_latest_version_info (tmp_location : String) return Boolean
   is
      sysroot       : constant String := HT.USS (PM.configuration.dir_sysroot);
      fetch_program : constant String := sysroot & "/usr/bin/fetch";
      cmd_output    : HT.Text;
      cmd           : constant String := fetch_program & " -q --no-verify-peer " &
                                         remote_version & " -o " & tmp_location;
      use type DIR.File_Kind;
   begin
      if not DIR.Exists ("/tmp") or else
        DIR.Kind ("/tmp") /= DIR.Directory
      then
         TIO.Put_Line ("The /tmp directory does not exist, bailing ...");
         return False;
      end if;
      if not DIR.Exists (fetch_program) then
         TIO.Put_Line ("It appears that the system root has not yet been installed at " & sysroot);
         TIO.Put_Line ("This must be rectified before Ravenports can be checked or fetched.");
         return False;
      end if;

      return Unix.piped_mute_command (cmd, cmd_output);
   end fetch_latest_version_info;

   --------------------------------------------------------------------------------------------
   --  fetch_latest_tarball
   --------------------------------------------------------------------------------------------
   function fetch_latest_tarball (latest_version : String) return Boolean
   is
      sysroot       : constant String := HT.USS (PM.configuration.dir_sysroot);
      fetch_program : constant String := sysroot & "/usr/bin/fetch";
      tarball       : constant String := github_archive & "/" & latest_version & ".tar.gz";
      cmd_output    : HT.Text;
      cmd : constant String := fetch_program & " -q " & tarball & " -o /tmp";
   begin
      --  covered by previous existence checks of fetch_latest_version_info
      return Unix.piped_mute_command (cmd, cmd_output);
   end fetch_latest_tarball;

   --------------------------------------------------------------------------------------------
   --  later_version_available
   --------------------------------------------------------------------------------------------
   function later_version_available (available : out Boolean) return String
   is
      consdir     : constant String := HT.USS (PM.configuration.dir_conspiracy);
      version_loc : constant String := consdir & conspiracy_version;
   begin
      available := True;
      --  We know consdir exists because we couldn't get here if it didn't.
      if fetch_latest_version_info (temporary_ver_loc) then
         declare
            latestver  : constant String := FOP.head_n1 (temporary_ver_loc);
         begin
            DIR.Delete_File (temporary_ver_loc);
            if DIR.Exists (version_loc) then
               declare
                  currentver : constant String := FOP.head_n1 (version_loc);
               begin
                  if latestver = currentver then
                     available := False;
                  end if;
               end;
            end if;
            return latestver;
         end;
      else
         available := False;
         TIO.Put_Line ("Failed to fetch latest version information from Github");
         return "";
      end if;
   end later_version_available;

   --------------------------------------------------------------------------------------------
   --  retrieve_latest_ravenports
   --------------------------------------------------------------------------------------------
   procedure retrieve_latest_ravenports
   is
      available      : Boolean;
      latest_version : constant String := later_version_available (available);
   begin
      if not available then
         TIO.Put_Line ("Ravenports update skipped as no new version is available.");
         return;
      end if;

      clean_up (latest_version);
      if not fetch_latest_tarball (latest_version) then
         TIO.Put_Line ("Ravenports update skipped as tarball download failed.");
         return;
      end if;

      if relocate_existing_ravenports and then
        explode_tarball_into_conspiracy (latest_version)
      then
         clean_up (latest_version);
      end if;
   end retrieve_latest_ravenports;

   --------------------------------------------------------------------------------------------
   --  retrieve_latest_ravenports
   --------------------------------------------------------------------------------------------
   function relocate_existing_ravenports return Boolean
   is
      consdir : constant String := HT.USS (PM.configuration.dir_conspiracy);
      consdir_old : constant String := consdir & ".old";
   begin
      DIR.Rename (Old_Name => consdir, New_Name => consdir_old);
      return True;
   exception
      when others =>
         return False;
   end relocate_existing_ravenports;

   --------------------------------------------------------------------------------------------
   --  explode_tarball_into_conspiracy
   --------------------------------------------------------------------------------------------
   function explode_tarball_into_conspiracy (latest_version : String) return Boolean
   is
      sysroot       : constant String := HT.USS (PM.configuration.dir_sysroot);
      consdir       : constant String := HT.USS (PM.configuration.dir_conspiracy);
      tar_program   : constant String := sysroot & "/usr/bin/tar";
      tarball       : constant String := "/tmp/" & latest_version & ".tar.gz";
      extract_dir   : constant String := "/tmp/Ravenports-" & latest_version;
      cmd_output    : HT.Text;
      command       : constant String := tar_program & " -C /tmp -xf " & tarball;
      command2      : constant String := sysroot & "/bin/mv " & extract_dir & " " & consdir;
   begin
      if Unix.piped_mute_command (command, cmd_output) then
         return Unix.piped_mute_command (command2, cmd_output);
      else
         return False;
      end if;
   end explode_tarball_into_conspiracy;

   --------------------------------------------------------------------------------------------
   --  clean_up
   --------------------------------------------------------------------------------------------
   procedure clean_up (latest_version : String)
   is
      sysroot     : constant String := HT.USS (PM.configuration.dir_sysroot);
      consdir     : constant String := HT.USS (PM.configuration.dir_conspiracy);
      consdir_old : constant String := consdir & ".old";
      extract_old : constant String := "/tmp/Ravenports-" & latest_version;
      command     : constant String := sysroot & "/bin/rm -rf " & consdir_old;
      command2    : constant String := sysroot & "/bin/rm -rf " & extract_old;
      tarball     : constant String := "/tmp/" & latest_version & ".tar.gz";
      cmd_output  : HT.Text;
      success     : Boolean;
   begin
      if DIR.Exists (consdir_old) then
         success := Unix.piped_mute_command (command, cmd_output);
      end if;
      if DIR.Exists (tarball) then
         DIR.Delete_File (tarball);
      end if;
      if DIR.Exists (extract_old) then
         success := Unix.piped_mute_command (command2, cmd_output);
      end if;
   exception
      when others => null;
   end clean_up;

end Ravenports;

--  This file is covered by the Internet Software Consortium (ISC) License
--  Reference: ../License.txt

with Parameters;
with HelperText;
with Unix;
with File_Operations;
with Ada.Directories;
with Ada.Text_IO;

package body Ravenports is

   package PM  renames Parameters;
   package HT  renames HelperText;
   package FOP renames File_Operations;
   package TIO renames Ada.Text_IO;
   package DIR renames Ada.Directories;

   --------------------------------------------------------------------------------------------
   --  check_version_available
   --------------------------------------------------------------------------------------------
   procedure check_version_available
   is
      consdir       : constant String := HT.USS (PM.configuration.dir_conspiracy);
      version_loc   : constant String := consdir & conspiracy_version;
   begin
      if DIR.Exists (version_loc) then
         if fetch_latest_version_info (temporary_ver_loc) then
            declare
               currentver : constant String := FOP.head_n1 (version_loc);
               latestver  : constant String := FOP.head_n1 (temporary_ver_loc);
            begin
               if latestver = currentver then
                  TIO.Put_Line ("The latest version of Ravenports, " & latestver &
                                  ", is currently installed.");
               else
                  TIO.Put_Line ("A newer version of Ravenports is available: " & latestver);
                  TIO.Put_Line ("The " & currentver & " version is currently installed.");
               end if;
            end;
            DIR.Delete_File (temporary_ver_loc);
         end if;
      else
         TIO.Put_Line ("It appears that Ravenports has not been installed at " & consdir);
      end if;
   exception
      when others => null;
   end check_version_available;

   --------------------------------------------------------------------------------------------
   --  fetch_latest_version_info
   --------------------------------------------------------------------------------------------
   function fetch_latest_version_info (tmp_location : String) return Boolean
   is
      sysroot       : constant String := HT.USS (PM.configuration.dir_sysroot);
      fetch_program : constant String := sysroot & "/usr/bin/fetch";
      cmd_output    : HT.Text;
      cmd           : constant String := fetch_program & " -q --no-verify-peer " &
                                         remote_version & " -o " & tmp_location;
      use type DIR.File_Kind;
   begin
      if not DIR.Exists ("/tmp") or else
        DIR.Kind ("/tmp") /= DIR.Directory
      then
         TIO.Put_Line ("The /tmp directory does not exist, bailing ...");
         return False;
      end if;
      if not DIR.Exists (fetch_program) then
         TIO.Put_Line ("It appears that the system root has not yet been installed at " & sysroot);
         TIO.Put_Line ("This must be rectified before Ravenports can be checked or fetched.");
         return False;
      end if;

      return Unix.piped_mute_command (cmd, cmd_output);
   end fetch_latest_version_info;

   --------------------------------------------------------------------------------------------
   --  fetch_latest_tarball
   --------------------------------------------------------------------------------------------
   function fetch_latest_tarball (latest_version : String) return Boolean
   is
      sysroot       : constant String := HT.USS (PM.configuration.dir_sysroot);
      fetch_program : constant String := sysroot & "/usr/bin/fetch";
      tarball       : constant String := github_archive & "/" & latest_version & ".tar.gz";
      cmd_output    : HT.Text;
      cmd : constant String := fetch_program & " -q " & tarball & " -o /tmp";
   begin
      --  covered by previous existence checks of fetch_latest_version_info
      return Unix.piped_mute_command (cmd, cmd_output);
   end fetch_latest_tarball;

   --------------------------------------------------------------------------------------------
   --  later_version_available
   --------------------------------------------------------------------------------------------
   function later_version_available (available : out Boolean) return String
   is
      consdir     : constant String := HT.USS (PM.configuration.dir_conspiracy);
      version_loc : constant String := consdir & conspiracy_version;
   begin
      available := True;
      --  We know consdir exists because we couldn't get here if it didn't.
      if fetch_latest_version_info (temporary_ver_loc) then
         declare
            latestver  : constant String := FOP.head_n1 (temporary_ver_loc);
         begin
            DIR.Delete_File (temporary_ver_loc);
            if DIR.Exists (version_loc) then
               declare
                  currentver : constant String := FOP.head_n1 (version_loc);
               begin
                  if latestver = currentver then
                     available := False;
                  end if;
               end;
            end if;
            return latestver;
         end;
      else
         available := False;
         TIO.Put_Line ("Failed to fetch latest version information from Github");
         return "";
      end if;
   end later_version_available;

   --------------------------------------------------------------------------------------------
   --  retrieve_latest_ravenports
   --------------------------------------------------------------------------------------------
   procedure retrieve_latest_ravenports
   is
      available      : Boolean;
      latest_version : constant String := later_version_available (available);
   begin
      if not available then
         TIO.Put_Line ("Ravenports update skipped as no new version is available.");
         return;
      end if;

      clean_up (latest_version);
      if not fetch_latest_tarball (latest_version) then
         TIO.Put_Line ("Ravenports update skipped as tarball download failed.");
         return;
      end if;

      if relocate_existing_ravenports and then
        explode_tarball_into_conspiracy (latest_version)
      then
         clean_up (latest_version);
      end if;
   end retrieve_latest_ravenports;

   --------------------------------------------------------------------------------------------
   --  retrieve_latest_ravenports
   --------------------------------------------------------------------------------------------
   function relocate_existing_ravenports return Boolean
   is
      consdir : constant String := HT.USS (PM.configuration.dir_conspiracy);
      consdir_old : constant String := consdir & ".old";
   begin
      DIR.Rename (Old_Name => consdir, New_Name => consdir_old);
      return True;
   exception
      when others =>
         return False;
   end relocate_existing_ravenports;

   --------------------------------------------------------------------------------------------
   --  explode_tarball_into_conspiracy
   --------------------------------------------------------------------------------------------
   function explode_tarball_into_conspiracy (latest_version : String) return Boolean
   is
      sysroot       : constant String := HT.USS (PM.configuration.dir_sysroot);
      consdir       : constant String := HT.USS (PM.configuration.dir_conspiracy);
      mv_program    : constant String := sysroot & "/bin/mv ";
      tar_program   : constant String := sysroot & "/usr/bin/tar ";
      find_program  : constant String := sysroot & "/usr/bin/find ";
      chmod_program : constant String := sysroot & "/bin/chmod ";
      tarball       : constant String := "/tmp/" & latest_version & ".tar.gz";
      extract_dir   : constant String := "/tmp/Ravenports-" & latest_version;
      cmd_output    : HT.Text;
      command       : constant String := tar_program & "-C /tmp -xf " & tarball;
      command2      : constant String := mv_program & extract_dir & " " & consdir;
      command3      : constant String := find_program & consdir & " -type d -exec " &
                                         chmod_program & "555 {} +";
   begin
      if Unix.piped_mute_command (command, cmd_output) and then
        Unix.piped_mute_command (command2, cmd_output)
      then
         return Unix.piped_mute_command (command3, cmd_output);
      else
         return False;
      end if;
   end explode_tarball_into_conspiracy;

   --------------------------------------------------------------------------------------------
   --  clean_up
   --------------------------------------------------------------------------------------------
   procedure clean_up (latest_version : String)
   is
      sysroot     : constant String := HT.USS (PM.configuration.dir_sysroot);
      consdir     : constant String := HT.USS (PM.configuration.dir_conspiracy);
      consdir_old : constant String := consdir & ".old";
      extract_old : constant String := "/tmp/Ravenports-" & latest_version;
      command     : constant String := sysroot & "/bin/rm -rf " & consdir_old;
      command2    : constant String := sysroot & "/bin/rm -rf " & extract_old;
      tarball     : constant String := "/tmp/" & latest_version & ".tar.gz";
      cmd_output  : HT.Text;
      success     : Boolean;
   begin
      if DIR.Exists (consdir_old) then
         success := Unix.piped_mute_command (command, cmd_output);
      end if;
      if DIR.Exists (tarball) then
         DIR.Delete_File (tarball);
      end if;
      if DIR.Exists (extract_old) then
         success := Unix.piped_mute_command (command2, cmd_output);
      end if;
   exception
      when others => null;
   end clean_up;

end Ravenports;

modify "update-ports" command

modify "update-ports" command

Set all directories of the conspiracy folder to "555" to effectively set
it as a read-only folder.


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

with MAT.Memory.Readers;
package body MAT.Memory.Targets is

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("MAT.Memory.Targets");

   --  ------------------------------
   --  Initialize the target memory object to manage the memory slots, the stack frames
   --  and setup the reader to analyze the memory events.
   --  ------------------------------
   procedure Initialize (Memory : in out Target_Memory;
                         Reader : in out MAT.Readers.Manager_Base'Class) is
      Memory_Reader : constant MAT.Memory.Readers.Memory_Reader_Access
        := new MAT.Memory.Readers.Memory_Servant;
   begin
      Memory.Reader := Memory_Reader.all'Access;
      Memory_Reader.Data := Memory'Unrestricted_Access;
      MAT.Memory.Readers.Register (Reader, Memory_Reader);
   end Initialize;

   --  ------------------------------
   --  Take into account a malloc probe.  The memory slot [Addr .. Slot.Size] is inserted
   --  in the used slots map.  The freed slots that intersect the malloc'ed region are
   --  removed from the freed map.
   --  ------------------------------
   procedure Probe_Malloc (Memory : in out Target_Memory;
                           Addr   : in MAT.Types.Target_Addr;
                           Slot   : in Allocation) is
   begin
      Memory.Memory.Probe_Malloc (Addr, Slot);
   end Probe_Malloc;

   --  ------------------------------
   --  Take into account a free probe.  Add the memory slot in the freed map and remove
   --  the slot from the used slots map.
   --  ------------------------------
   procedure Probe_Free (Memory : in out Target_Memory;
                         Addr   : in MAT.Types.Target_Addr;
                         Slot   : in Allocation) is
   begin
      Memory.Memory.Probe_Free (Addr, Slot);
   end Probe_Free;

   --  ------------------------------
   --  Take into account a realloc probe.  The old memory slot represented by Old_Addr is
   --  removed from the used slots maps and the new memory slot [Addr .. Slot.Size] is
   --  inserted in the used slots map.
   --  ------------------------------
   procedure Probe_Realloc (Memory : in out Target_Memory;
                            Addr     : in MAT.Types.Target_Addr;
                            Old_Addr : in MAT.Types.Target_Addr;
                            Slot     : in Allocation) is
   begin
      Memory.Memory.Probe_Realloc (Addr, Old_Addr, Slot);
   end Probe_Realloc;

   --  ------------------------------
   --  Insert in the frame tree the new stack frame represented by <tt>Pc</tt>.
   --  If the frame is already known, the frame reference counter is incremented.
   --  The frame represented by <tt>Pc</tt> is returned in <tt>Result</tt>.
   --  ------------------------------
   procedure Create_Frame (Memory : in out Target_Memory;
                           Pc     : in MAT.Frames.Frame_Table;
                           Result : out MAT.Frames.Frame_Type) is
   begin
      Memory.Memory.Create_Frame (Pc, Result);
   end Create_Frame;

   --  ------------------------------
   --  Collect the information about memory slot sizes allocated by the application.
   --  ------------------------------
   procedure Size_Information (Memory : in out Target_Memory;
                               Sizes  : in out MAT.Memory.Tools.Size_Info_Map) is
   begin
      Memory.Memory.Size_Information (Sizes);
   end Size_Information;

   --  ------------------------------
   --  Collect the information about threads and the memory allocations they've made.
   --  ------------------------------
   procedure Thread_Information (Memory  : in out Target_Memory;
                                 Threads : in out Memory_Info_Map) is
   begin
      Memory.Memory.Thread_Information (Threads);
   end Thread_Information;

   --  ------------------------------
   --  Find from the <tt>Memory</tt> map the memory slots whose address intersects
   --  the region [From .. To] and which is selected by the given filter expression.
   --  Add the memory slot in the <tt>Into</tt> list if it does not already contains
   --  the memory slot.
   --  ------------------------------
   procedure Find (Memory : in out Target_Memory;
                   From   : in MAT.Types.Target_Addr;
                   To     : in MAT.Types.Target_Addr;
                   Filter : in MAT.Expressions.Expression_Type;
                   Into   : in out MAT.Memory.Allocation_Map) is
   begin
      Memory.Memory.Find (From, To, Filter, Into);
   end Find;

   protected body Memory_Allocator is

      --  ------------------------------
      --  Remove the memory region [Addr .. Addr + Size] from the free list.
      --  ------------------------------
      procedure Remove_Free (Addr : in MAT.Types.Target_Addr;
                             Size : in MAT.Types.Target_Size) is
         Iter : Allocation_Cursor;
         Last : constant MAT.Types.Target_Addr := Addr + MAT.Types.Target_Addr (Size);
         Slot : Allocation;
      begin
         --  Walk the list of free blocks and remove all the blocks which intersect the region
         --  [Addr .. Addr + Slot.Size].  We start walking at the first block below and near
         --  the address.  Slots are then removed when they intersect the malloc'ed region.
         Iter := Freed_Slots.Floor (Addr);
         while Allocation_Maps.Has_Element (Iter) loop
            declare
               Freed_Addr : constant MAT.Types.Target_Addr := Allocation_Maps.Key (Iter);
            begin
               exit when Freed_Addr > Last;
               Slot := Allocation_Maps.Element (Iter);
               if Freed_Addr + MAT.Types.Target_Addr (Slot.Size) > Addr then
                  Freed_Slots.Delete (Iter);
                  Iter := Freed_Slots.Floor (Addr);
               else
                  Allocation_Maps.Next (Iter);
               end if;
            end;
         end loop;
      end Remove_Free;

      --  ------------------------------
      --  Take into account a malloc probe.  The memory slot [Addr .. Slot.Size] is inserted
      --  in the used slots map.  The freed slots that intersect the malloc'ed region are
      --  removed from the freed map.
      --  ------------------------------
      procedure Probe_Malloc (Addr   : in MAT.Types.Target_Addr;
                              Slot   : in Allocation) is
      begin
         if Log.Get_Level = Util.Log.DEBUG_LEVEL then
            Log.Debug ("Malloc at {0} size {1}", MAT.Types.Hex_Image (Addr),
                       MAT.Types.Target_Size'Image (Slot.Size));
         end if;
         Remove_Free (Addr, Slot.Size);
         Used_Slots.Insert (Addr, Slot);
      end Probe_Malloc;

      --  ------------------------------
      --  Take into account a free probe.  Add the memory slot in the freed map and remove
      --  the slot from the used slots map.
      --  ------------------------------
      procedure Probe_Free (Addr   : in MAT.Types.Target_Addr;
                            Slot   : in Allocation) is
         Item : Allocation;
         Iter : Allocation_Cursor;
      begin
         if Log.Get_Level = Util.Log.DEBUG_LEVEL then
            Log.Debug ("Free {0}", MAT.Types.Hex_Image (Addr));
         end if;
         Iter := Used_Slots.Find (Addr);
         if Allocation_Maps.Has_Element (Iter) then
            Item := Allocation_Maps.Element (Iter);
            MAT.Frames.Release (Item.Frame);
            Used_Slots.Delete (Iter);
            Item.Frame := Slot.Frame;
            Freed_Slots.Insert (Addr, Item);
         end if;
      end Probe_Free;

      --  ------------------------------
      --  Take into account a realloc probe.  The old memory slot represented by Old_Addr is
      --  removed from the used slots maps and the new memory slot [Addr .. Slot.Size] is
      --  inserted in the used slots map.
      --  ------------------------------
      procedure Probe_Realloc (Addr     : in MAT.Types.Target_Addr;
                               Old_Addr : in MAT.Types.Target_Addr;
                               Slot     : in Allocation) is
         procedure Update_Size (Key     : in MAT.Types.Target_Addr;
                                Element : in out Allocation);

         procedure Update_Size (Key     : in MAT.Types.Target_Addr;
                                Element : in out Allocation) is
            pragma Unreferenced (Key);
         begin
            Element.Size := Slot.Size;
            MAT.Frames.Release (Element.Frame);
            Element.Frame := Slot.Frame;
         end Update_Size;

         Pos      : Allocation_Cursor;
      begin
         if Log.Get_Level = Util.Log.DEBUG_LEVEL then
            Log.Debug ("Realloc {0} to {1} size {2}", MAT.Types.Hex_Image (Old_Addr),
                       MAT.Types.Hex_Image (Addr), MAT.Types.Target_Size'Image (Slot.Size));
         end if;
         if Addr /= 0 then
            Pos := Used_Slots.Find (Old_Addr);
            if Allocation_Maps.Has_Element (Pos) then
               if Addr = Old_Addr then
                  Used_Slots.Update_Element (Pos, Update_Size'Access);
               else
                  Used_Slots.Delete (Pos);
                  Used_Slots.Insert (Addr, Slot);
               end if;
            else
               Used_Slots.Insert (Addr, Slot);
            end if;
            Remove_Free (Addr, Slot.Size);
         end if;
      end Probe_Realloc;

      --  ------------------------------
      --  Insert in the frame tree the new stack frame represented by <tt>Pc</tt>.
      --  If the frame is already known, the frame reference counter is incremented.
      --  The frame represented by <tt>Pc</tt> is returned in <tt>Result</tt>.
      --  ------------------------------
      procedure Create_Frame (Pc     : in MAT.Frames.Frame_Table;
                              Result : out MAT.Frames.Frame_Type) is
      begin
         MAT.Frames.Insert (Frames, Pc, Result);
      end Create_Frame;

      --  ------------------------------
      --  Collect the information about memory slot sizes allocated by the application.
      --  ------------------------------
      procedure Size_Information (Sizes  : in out MAT.Memory.Tools.Size_Info_Map) is
      begin
         MAT.Memory.Tools.Size_Information (Used_Slots, Sizes);
      end Size_Information;

      --  ------------------------------
      --  Collect the information about threads and the memory allocations they've made.
      --  ------------------------------
      procedure Thread_Information (Threads : in out Memory_Info_Map) is
      begin
         MAT.Memory.Tools.Thread_Information (Used_Slots, Threads);
      end Thread_Information;

      --  ------------------------------
      --  Find from the <tt>Memory</tt> map the memory slots whose address intersects
      --  the region [From .. To] and which is selected by the given filter expression.
      --  Add the memory slot in the <tt>Into</tt> list if it does not already contains
      --  the memory slot.
      --  ------------------------------
      procedure Find (From   : in MAT.Types.Target_Addr;
                      To     : in MAT.Types.Target_Addr;
                      Filter : in MAT.Expressions.Expression_Type;
                      Into   : in out MAT.Memory.Allocation_Map) is
      begin
         MAT.Memory.Tools.Find (Used_Slots, From, To, Filter, Into);
      end Find;

   end Memory_Allocator;

end MAT.Memory.Targets;

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

with MAT.Memory.Readers;
package body MAT.Memory.Targets is

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("MAT.Memory.Targets");

   --  ------------------------------
   --  Initialize the target memory object to manage the memory slots, the stack frames
   --  and setup the reader to analyze the memory events.
   --  ------------------------------
   procedure Initialize (Memory : in out Target_Memory;
                         Reader : in out MAT.Readers.Manager_Base'Class) is
      Memory_Reader : constant MAT.Memory.Readers.Memory_Reader_Access
        := new MAT.Memory.Readers.Memory_Servant;
   begin
      Memory.Reader := Memory_Reader.all'Access;
      Memory_Reader.Data := Memory'Unrestricted_Access;
      MAT.Memory.Readers.Register (Reader, Memory_Reader);
   end Initialize;

   --  ------------------------------
   --  Take into account a malloc probe.  The memory slot [Addr .. Slot.Size] is inserted
   --  in the used slots map.  The freed slots that intersect the malloc'ed region are
   --  removed from the freed map.
   --  ------------------------------
   procedure Probe_Malloc (Memory : in out Target_Memory;
                           Addr   : in MAT.Types.Target_Addr;
                           Slot   : in Allocation) is
   begin
      Memory.Memory.Probe_Malloc (Addr, Slot);
   end Probe_Malloc;

   --  ------------------------------
   --  Take into account a free probe.  Add the memory slot in the freed map and remove
   --  the slot from the used slots map.
   --  ------------------------------
   procedure Probe_Free (Memory : in out Target_Memory;
                         Addr   : in MAT.Types.Target_Addr;
                         Slot   : in Allocation) is
   begin
      Memory.Memory.Probe_Free (Addr, Slot);
   end Probe_Free;

   --  ------------------------------
   --  Take into account a realloc probe.  The old memory slot represented by Old_Addr is
   --  removed from the used slots maps and the new memory slot [Addr .. Slot.Size] is
   --  inserted in the used slots map.
   --  ------------------------------
   procedure Probe_Realloc (Memory : in out Target_Memory;
                            Addr     : in MAT.Types.Target_Addr;
                            Old_Addr : in MAT.Types.Target_Addr;
                            Slot     : in Allocation) is
   begin
      Memory.Memory.Probe_Realloc (Addr, Old_Addr, Slot);
   end Probe_Realloc;

   --  ------------------------------
   --  Insert in the frame tree the new stack frame represented by <tt>Pc</tt>.
   --  If the frame is already known, the frame reference counter is incremented.
   --  The frame represented by <tt>Pc</tt> is returned in <tt>Result</tt>.
   --  ------------------------------
   procedure Create_Frame (Memory : in out Target_Memory;
                           Pc     : in MAT.Frames.Frame_Table;
                           Result : out MAT.Frames.Frame_Type) is
   begin
      Memory.Memory.Create_Frame (Pc, Result);
   end Create_Frame;

   --  ------------------------------
   --  Collect the information about memory slot sizes allocated by the application.
   --  ------------------------------
   procedure Size_Information (Memory : in out Target_Memory;
                               Sizes  : in out MAT.Memory.Tools.Size_Info_Map) is
   begin
      Memory.Memory.Size_Information (Sizes);
   end Size_Information;

   --  ------------------------------
   --  Collect the information about threads and the memory allocations they've made.
   --  ------------------------------
   procedure Thread_Information (Memory  : in out Target_Memory;
                                 Threads : in out Memory_Info_Map) is
   begin
      Memory.Memory.Thread_Information (Threads);
   end Thread_Information;

   --  ------------------------------
   --  Collect the information about frames and the memory allocations they've made.
   --  ------------------------------
   procedure Frame_Information (Memory : in out Target_Memory;
                                Level  : in Natural;
                                Frames : in out Frame_Info_Map) is
   begin
      Memory.Memory.Frame_Information (Level, Frames);
   end Frame_Information;

   --  ------------------------------
   --  Find from the <tt>Memory</tt> map the memory slots whose address intersects
   --  the region [From .. To] and which is selected by the given filter expression.
   --  Add the memory slot in the <tt>Into</tt> list if it does not already contains
   --  the memory slot.
   --  ------------------------------
   procedure Find (Memory : in out Target_Memory;
                   From   : in MAT.Types.Target_Addr;
                   To     : in MAT.Types.Target_Addr;
                   Filter : in MAT.Expressions.Expression_Type;
                   Into   : in out MAT.Memory.Allocation_Map) is
   begin
      Memory.Memory.Find (From, To, Filter, Into);
   end Find;

   protected body Memory_Allocator is

      --  ------------------------------
      --  Remove the memory region [Addr .. Addr + Size] from the free list.
      --  ------------------------------
      procedure Remove_Free (Addr : in MAT.Types.Target_Addr;
                             Size : in MAT.Types.Target_Size) is
         Iter : Allocation_Cursor;
         Last : constant MAT.Types.Target_Addr := Addr + MAT.Types.Target_Addr (Size);
         Slot : Allocation;
      begin
         --  Walk the list of free blocks and remove all the blocks which intersect the region
         --  [Addr .. Addr + Slot.Size].  We start walking at the first block below and near
         --  the address.  Slots are then removed when they intersect the malloc'ed region.
         Iter := Freed_Slots.Floor (Addr);
         while Allocation_Maps.Has_Element (Iter) loop
            declare
               Freed_Addr : constant MAT.Types.Target_Addr := Allocation_Maps.Key (Iter);
            begin
               exit when Freed_Addr > Last;
               Slot := Allocation_Maps.Element (Iter);
               if Freed_Addr + MAT.Types.Target_Addr (Slot.Size) > Addr then
                  Freed_Slots.Delete (Iter);
                  Iter := Freed_Slots.Floor (Addr);
               else
                  Allocation_Maps.Next (Iter);
               end if;
            end;
         end loop;
      end Remove_Free;

      --  ------------------------------
      --  Take into account a malloc probe.  The memory slot [Addr .. Slot.Size] is inserted
      --  in the used slots map.  The freed slots that intersect the malloc'ed region are
      --  removed from the freed map.
      --  ------------------------------
      procedure Probe_Malloc (Addr   : in MAT.Types.Target_Addr;
                              Slot   : in Allocation) is
      begin
         if Log.Get_Level = Util.Log.DEBUG_LEVEL then
            Log.Debug ("Malloc at {0} size {1}", MAT.Types.Hex_Image (Addr),
                       MAT.Types.Target_Size'Image (Slot.Size));
         end if;
         Remove_Free (Addr, Slot.Size);
         Used_Slots.Insert (Addr, Slot);
      end Probe_Malloc;

      --  ------------------------------
      --  Take into account a free probe.  Add the memory slot in the freed map and remove
      --  the slot from the used slots map.
      --  ------------------------------
      procedure Probe_Free (Addr   : in MAT.Types.Target_Addr;
                            Slot   : in Allocation) is
         Item : Allocation;
         Iter : Allocation_Cursor;
      begin
         if Log.Get_Level = Util.Log.DEBUG_LEVEL then
            Log.Debug ("Free {0}", MAT.Types.Hex_Image (Addr));
         end if;
         Iter := Used_Slots.Find (Addr);
         if Allocation_Maps.Has_Element (Iter) then
            Item := Allocation_Maps.Element (Iter);
            MAT.Frames.Release (Item.Frame);
            Used_Slots.Delete (Iter);
            Item.Frame := Slot.Frame;
            Freed_Slots.Insert (Addr, Item);
         end if;
      end Probe_Free;

      --  ------------------------------
      --  Take into account a realloc probe.  The old memory slot represented by Old_Addr is
      --  removed from the used slots maps and the new memory slot [Addr .. Slot.Size] is
      --  inserted in the used slots map.
      --  ------------------------------
      procedure Probe_Realloc (Addr     : in MAT.Types.Target_Addr;
                               Old_Addr : in MAT.Types.Target_Addr;
                               Slot     : in Allocation) is
         procedure Update_Size (Key     : in MAT.Types.Target_Addr;
                                Element : in out Allocation);

         procedure Update_Size (Key     : in MAT.Types.Target_Addr;
                                Element : in out Allocation) is
            pragma Unreferenced (Key);
         begin
            Element.Size := Slot.Size;
            MAT.Frames.Release (Element.Frame);
            Element.Frame := Slot.Frame;
         end Update_Size;

         Pos      : Allocation_Cursor;
      begin
         if Log.Get_Level = Util.Log.DEBUG_LEVEL then
            Log.Debug ("Realloc {0} to {1} size {2}", MAT.Types.Hex_Image (Old_Addr),
                       MAT.Types.Hex_Image (Addr), MAT.Types.Target_Size'Image (Slot.Size));
         end if;
         if Addr /= 0 then
            Pos := Used_Slots.Find (Old_Addr);
            if Allocation_Maps.Has_Element (Pos) then
               if Addr = Old_Addr then
                  Used_Slots.Update_Element (Pos, Update_Size'Access);
               else
                  Used_Slots.Delete (Pos);
                  Used_Slots.Insert (Addr, Slot);
               end if;
            else
               Used_Slots.Insert (Addr, Slot);
            end if;
            Remove_Free (Addr, Slot.Size);
         end if;
      end Probe_Realloc;

      --  ------------------------------
      --  Insert in the frame tree the new stack frame represented by <tt>Pc</tt>.
      --  If the frame is already known, the frame reference counter is incremented.
      --  The frame represented by <tt>Pc</tt> is returned in <tt>Result</tt>.
      --  ------------------------------
      procedure Create_Frame (Pc     : in MAT.Frames.Frame_Table;
                              Result : out MAT.Frames.Frame_Type) is
      begin
         MAT.Frames.Insert (Frames, Pc, Result);
      end Create_Frame;

      --  ------------------------------
      --  Collect the information about memory slot sizes allocated by the application.
      --  ------------------------------
      procedure Size_Information (Sizes  : in out MAT.Memory.Tools.Size_Info_Map) is
      begin
         MAT.Memory.Tools.Size_Information (Used_Slots, Sizes);
      end Size_Information;

      --  ------------------------------
      --  Collect the information about threads and the memory allocations they've made.
      --  ------------------------------
      procedure Thread_Information (Threads : in out Memory_Info_Map) is
      begin
         MAT.Memory.Tools.Thread_Information (Used_Slots, Threads);
      end Thread_Information;

      --  ------------------------------
      --  Collect the information about frames and the memory allocations they've made.
      --  ------------------------------
      procedure Frame_Information (Level  : in Natural;
                                   Frames : in out Frame_Info_Map) is
      begin
         MAT.Memory.Tools.Frame_Information (Used_Slots, Level, Frames);
      end Frame_Information;

      --  ------------------------------
      --  Find from the <tt>Memory</tt> map the memory slots whose address intersects
      --  the region [From .. To] and which is selected by the given filter expression.
      --  Add the memory slot in the <tt>Into</tt> list if it does not already contains
      --  the memory slot.
      --  ------------------------------
      procedure Find (From   : in MAT.Types.Target_Addr;
                      To     : in MAT.Types.Target_Addr;
                      Filter : in MAT.Expressions.Expression_Type;
                      Into   : in out MAT.Memory.Allocation_Map) is
      begin
         MAT.Memory.Tools.Find (Used_Slots, From, To, Filter, Into);
      end Find;

   end Memory_Allocator;

end MAT.Memory.Targets;

Implement the Frame_Information procedure and protected operation