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

   subtype Format_Map is Wiki.Documents.Format_Map;
   subtype WString is Wide_Wide_String;

   type Node_Kind is (N_HEADER,
                      N_LINE_BREAK,
                      N_HORIZONTAL_RULE,
                      N_PARAGRAPH,
                      N_BLOCKQUOTE,
                      N_QUOTE,
                      N_TAG_START,
                      N_TAG_END,
                      N_INDENT,
                      N_TEXT,
                      N_LINK,
                      N_IMAGE);

   --  The possible HTML tags as described in HTML5 specification.
   type Html_Tag_Type is
     (
      --  Section 4.1 The root element
      HTML_TAG,

      --  Section 4.2 Document metadata
      HEAD_TAG, TITLE_TAG, BASE_TAG, LINK_TAG, META_TAG, STYLE_TAG,

      --  Section 4.3 Sections
      BODY_TAG, ARTICLE_TAG, SECTION_TAG, NAV_TAG, ASIDE_TAG,
      H1_TAG, H2_TAG, H3_TAG, H4_TAG, H5_TAG, H6_TAG,
      HEADER_TAG, FOOTER_TAG,
      ADDRESS_TAG,

      --  Section 4.4 Grouping content
      P_TAG, HR_TAG, PRE_TAG, BLOCKQUOTE_TAG,
      OL_TAG, UL_TAG, LI_TAG,
      DL_TAG, DT_TAG, DD_TAG,
      FIGURE_TAG, FIGCAPTION_TAG,
      DIV_TAG, MAIN_TAG,

      --  Section 4.5 Text-level semantics
      A_TAG, EM_TAG, STRONG_TAG, SMALL_TAG,
      S_TAG, CITE_TAG, Q_TAG, DFN_TAG, ABBR_TAG,
      DATA_TAG, TIME_TAG, CODE_TAG, VAR_TAG, SAMP_TAG,
      KBD_TAG, SUB_TAG, SUP_TAG,
      I_TAG, B_TAG, U_TAG,
      MARK_TAG, RUBY_TAG, RB_TAG, RT_TAG, RTC_TAG,
      RP_TAG, BDI_TAG, BDO_TAG, SPAN_TAG,
      BR_TAG, WBR_TAG,

      --  Section 4.6 Edits
      INS_TAG, DEL_TAG,

      --  Section 4.7 Embedded content
      IMG_TAG,
      IFRAME_TAG,
      EMBED_TAG,
      OBJECT_TAG,
      PARAM_TAG,
      VIDEO_TAG,
      AUDIO_TAG,
      SOURCE_TAG,
      TRACK_TAG,
      MAP_TAG,
      AREA_TAG,

      --  Section 4.9 Tabular data
      TABLE_TAG, CAPTION_TAG, COLGROUP_TAG, COL_TAG,
      TBODY_TAG, THEAD_TAG, TFOOT_TAG,
      TR_TAG, TD_TAG, TH_TAG,

      --  Section 4.10 Forms
      FORM_TAG, LABEL_TAG, INPUT_TAG,
      BUTTON_TAG, SELECT_TAG, DATALIST_TAG, OPTGROUP_TAG,
      OPTION_TAG, TEXTAREA_TAG, KEYGEN_TAG, OUTPUT_TAG,
      PROGRESS_TAG, METER_TAG, FIELDSET_TAG, LEGEND_TAG,

      --  Section 4.11 Scripting
      SCRIPT_TAG, NOSCRIPT_TAG,
      TEMPLATE_TAG, CANVAS_TAG,

      --  Unknown tags
      UNKNOWN_TAG
     );

   type Node_List is limited private;
   type Node_List_Access is access all Node_List;

   type Node_Type (Kind : Node_Kind; Len : Natural) is limited record
      case Kind is
         when N_HEADER | N_BLOCKQUOTE | N_INDENT =>
            Level  : Natural := 0;
            Header : WString (1 .. Len);

         when N_TEXT =>
            Format : Format_Map;
            Text   : WString (1 .. Len);

         when N_LINK | N_IMAGE =>
            Link       : Wiki.Attributes.Attribute_List_Type;

         when N_QUOTE =>
            Quote      : WString (1 .. Len);

         when N_TAG_START =>
            Tag_Start  : Html_Tag_Type;
            Attributes : Wiki.Attributes.Attribute_List_Type;
            Children   : Node_List_Access;

         when N_TAG_END =>
            Tag_End    : Html_Tag_Type;

         when others =>
            null;

      end case;
   end record;
   type Node_Type_Access is access all Node_Type;

   type Document_Node_Access is private;
   type Document is limited private;

   --  Create a text node.
   function Create_Text (Text : in WString) return Node_Type_Access;

   --     procedure Add_Text (Doc  : in out Document;
--                         Text : in WString);

--     type Renderer is limited interface;
--
--     procedure Render (Engine : in out Renderer;
--                       Doc    : in Document;
--                       Node   : in Node_Type) is abstract;
--
--     procedure Iterate (Doc     : in Document;
--                        Process : access procedure (Doc : in Document; Node : in Node_Type)) is
--        Node : Document_Node_Access := Doc.First;
--     begin
--        while Node /= null loop
--           Process (Doc, Node.Data);
--           Node := Node.Next;
--        end loop;
--     end Iterate;

private

   type Node_List is limited record
      N : Natural;
   end record;

   type Document_Node;

   type Document_Node_Access is access all Document_Node;

   type Document_Node (Kind : Node_Kind; Len : Natural) is limited record
      Next  : Document_Node_Access;
      Prev  : Document_Node_Access;
      Data  : Node_Type (Kind, Len);
   end record;

   type Document is limited record
      First : Document_Node_Access;
      Last  : Document_Node_Access;
   end record;

end Wiki.Nodes;

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

   subtype Format_Map is Wiki.Documents.Format_Map;
   subtype WString is Wide_Wide_String;

   type Node_Kind is (N_HEADER,
                      N_LINE_BREAK,
                      N_HORIZONTAL_RULE,
                      N_PARAGRAPH,
                      N_BLOCKQUOTE,
                      N_QUOTE,
                      N_TAG_START,
                      N_TAG_END,
                      N_INDENT,
                      N_TEXT,
                      N_LINK,
                      N_IMAGE);

   --  The possible HTML tags as described in HTML5 specification.
   type Html_Tag_Type is
     (
      --  Section 4.1 The root element
      HTML_TAG,

      --  Section 4.2 Document metadata
      HEAD_TAG, TITLE_TAG, BASE_TAG, LINK_TAG, META_TAG, STYLE_TAG,

      --  Section 4.3 Sections
      BODY_TAG, ARTICLE_TAG, SECTION_TAG, NAV_TAG, ASIDE_TAG,
      H1_TAG, H2_TAG, H3_TAG, H4_TAG, H5_TAG, H6_TAG,
      HEADER_TAG, FOOTER_TAG,
      ADDRESS_TAG,

      --  Section 4.4 Grouping content
      P_TAG, HR_TAG, PRE_TAG, BLOCKQUOTE_TAG,
      OL_TAG, UL_TAG, LI_TAG,
      DL_TAG, DT_TAG, DD_TAG,
      FIGURE_TAG, FIGCAPTION_TAG,
      DIV_TAG, MAIN_TAG,

      --  Section 4.5 Text-level semantics
      A_TAG, EM_TAG, STRONG_TAG, SMALL_TAG,
      S_TAG, CITE_TAG, Q_TAG, DFN_TAG, ABBR_TAG,
      DATA_TAG, TIME_TAG, CODE_TAG, VAR_TAG, SAMP_TAG,
      KBD_TAG, SUB_TAG, SUP_TAG,
      I_TAG, B_TAG, U_TAG,
      MARK_TAG, RUBY_TAG, RB_TAG, RT_TAG, RTC_TAG,
      RP_TAG, BDI_TAG, BDO_TAG, SPAN_TAG,
      BR_TAG, WBR_TAG,

      --  Section 4.6 Edits
      INS_TAG, DEL_TAG,

      --  Section 4.7 Embedded content
      IMG_TAG,
      IFRAME_TAG,
      EMBED_TAG,
      OBJECT_TAG,
      PARAM_TAG,
      VIDEO_TAG,
      AUDIO_TAG,
      SOURCE_TAG,
      TRACK_TAG,
      MAP_TAG,
      AREA_TAG,

      --  Section 4.9 Tabular data
      TABLE_TAG, CAPTION_TAG, COLGROUP_TAG, COL_TAG,
      TBODY_TAG, THEAD_TAG, TFOOT_TAG,
      TR_TAG, TD_TAG, TH_TAG,

      --  Section 4.10 Forms
      FORM_TAG, LABEL_TAG, INPUT_TAG,
      BUTTON_TAG, SELECT_TAG, DATALIST_TAG, OPTGROUP_TAG,
      OPTION_TAG, TEXTAREA_TAG, KEYGEN_TAG, OUTPUT_TAG,
      PROGRESS_TAG, METER_TAG, FIELDSET_TAG, LEGEND_TAG,

      --  Section 4.11 Scripting
      SCRIPT_TAG, NOSCRIPT_TAG,
      TEMPLATE_TAG, CANVAS_TAG,

      --  Unknown tags
      UNKNOWN_TAG
     );

   type Node_List is limited private;
   type Node_List_Access is access all Node_List;

   type Node_Type (Kind : Node_Kind; Len : Natural) is limited record
      case Kind is
         when N_HEADER | N_BLOCKQUOTE | N_INDENT =>
            Level  : Natural := 0;
            Header : WString (1 .. Len);

         when N_TEXT =>
            Format : Format_Map;
            Text   : WString (1 .. Len);

         when N_LINK | N_IMAGE =>
            Link       : Wiki.Attributes.Attribute_List_Type;

         when N_QUOTE =>
            Quote      : WString (1 .. Len);

         when N_TAG_START =>
            Tag_Start  : Html_Tag_Type;
            Attributes : Wiki.Attributes.Attribute_List_Type;
            Children   : Node_List_Access;

         when N_TAG_END =>
            Tag_End    : Html_Tag_Type;

         when others =>
            null;

      end case;
   end record;
   type Node_Type_Access is access all Node_Type;

   type Document_Node_Access is private;
   type Document is limited private;

   --  Create a text node.
   function Create_Text (Text : in WString) return Node_Type_Access;

   --     procedure Add_Text (Doc  : in out Document;
--                         Text : in WString);

--     type Renderer is limited interface;
--
--     procedure Render (Engine : in out Renderer;
--                       Doc    : in Document;
--                       Node   : in Node_Type) is abstract;
--
--     procedure Iterate (Doc     : in Document;
--                        Process : access procedure (Doc : in Document; Node : in Node_Type)) is
--        Node : Document_Node_Access := Doc.First;
--     begin
--        while Node /= null loop
--           Process (Doc, Node.Data);
--           Node := Node.Next;
--        end loop;
--     end Iterate;

private

   NODE_LIST_BLOCK_SIZE : constant Positive := 20;

   type Node_Array is array (Positive range <>) of Node_Type_Access;

   type Node_List_Block;
   type Node_List_Block_Access is access all Node_List_Block;

   type Node_List_Block (Max : Positive) is limited record
      Next  : Node_List_Block;
      Last  : Natural := 0;
      List  : Node_Array (1 .. Max);
   end record;

   type Node_List is limited record
      Current : Node_List_Block_Access;
      Length  : Natural := 0;
      First   : Node_List_Block (NODE_LIST_BLOCK_SIZE);
   end record;

   type Document_Node;

   type Document_Node_Access is access all Document_Node;

   type Document_Node (Kind : Node_Kind; Len : Natural) is limited record
      Next  : Document_Node_Access;
      Prev  : Document_Node_Access;
      Data  : Node_Type (Kind, Len);
   end record;

   type Document is limited record
      First : Document_Node_Access;
      Last  : Document_Node_Access;
   end record;

end Wiki.Nodes;

Declare Node_List_Block and Node_List types


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

   use EL.Objects;

   TITLE_ATTR         : aliased constant String := "title";
   STYLE_ATTR         : aliased constant String := "style";
   STYLE_CLASS_ATTR   : aliased constant String := "styleClass";
   DIR_ATTR           : aliased constant String := "dir";
   LANG_ATTR          : aliased constant String := "lang";

   ACCESS_KEY_ATTR    : aliased constant String := "accesskey";
   ON_BLUR_ATTR       : aliased constant String := "onblur";
   ON_CLICK_ATTR      : aliased constant String := "onclick";
   ON_DBLCLICK_ATTR   : aliased constant String := "ondblclick";
   ON_FOCUS_ATTR      : aliased constant String := "onfocus";
   ON_KEYDOWN_ATTR    : aliased constant String := "onkeydown";
   ON_KEYUP_ATTR      : aliased constant String := "onkeyup";
   ON_MOUSE_DOWN_ATTR : aliased constant String := "onmousedown";
   ON_MOUSE_MOVE_ATTR : aliased constant String := "onmousemove";
   ON_MOUSE_OUT_ATTR  : aliased constant String := "onmouseout";
   ON_MOUSE_OVER_ATTR : aliased constant String := "onmouseover";
   ON_MOUSE_UP_ATTR   : aliased constant String := "onmouseup";

   TABINDEX_ATTR      : aliased constant String := "tabindex";

   procedure Render_Attributes (UI      : in UIHtmlComponent;
                                Context : in out Faces_Context'Class;
                                Writer  : in ResponseWriter_Access) is
      Style  : constant Object := UI.Get_Attribute (Context, "style");
      Class  : constant Object := UI.Get_Attribute (Context, "styleClass");
      Title  : constant Object := UI.Get_Attribute (Context, "title");
   begin
      Writer.Write_Attribute ("id", UI.Get_Client_Id);
      if not Is_Null (Class) then
         Writer.Write_Attribute ("class", Class);
      end if;
      if not Is_Null (Style) then
         Writer.Write_Attribute ("style", Style);
      end if;
      if not Is_Null (Title) then
         Writer.Write_Attribute ("title", Title);
      end if;
   end Render_Attributes;

   --  ------------------------------
   --  Render the attributes which are defined on the component and which are
   --  in the list specified by names.
   --  ------------------------------
   procedure Render_Attributes (UI      : in UIHtmlComponent;
                                Context : in out Faces_Context'Class;
                                Names   : in Util.Strings.String_Set.Set;
                                Writer  : in ResponseWriter_Access) is

      procedure Process_Attribute (Name : in String;
                                   Attr : in UIAttribute) is
      begin
         if Names.Contains (Name'Unrestricted_Access) then
            declare
               Value : constant Object := Get_Value (Attr, UI);
            begin
               if Name = "styleClass" then
                  Writer.Write_Attribute ("class", Value);
               else
                  Writer.Write_Attribute (Name, Value);
               end if;
            end;
         end if;
      end Process_Attribute;

      procedure Write_Attributes is new Iterate_Attributes (Process_Attribute);

      Id : constant Unbounded_String := UI.Get_Client_Id;
   begin
      if Length (Id) > 0 then
         Writer.Write_Attribute ("id", UI.Get_Client_Id);
      end if;
      Write_Attributes (UI);
   end Render_Attributes;

   --  ------------------------------
   --  Add in the names set, the basic text attributes that can be set
   --  on HTML elements (dir, lang, style, title).
   --  ------------------------------
   procedure Set_Text_Attributes (Names : in out Util.Strings.String_Set.Set) is
   begin
      Names.Insert (STYLE_CLASS_ATTR'Access);
      Names.Insert (TITLE_ATTR'Access);
      Names.Insert (DIR_ATTR'Access);
      Names.Insert (LANG_ATTR'Access);
      Names.Insert (STYLE_ATTR'Access);
   end Set_Text_Attributes;

   --  ------------------------------
   --  Add in the names set, the onXXX attributes that can be set
   --  on HTML elements (accesskey, tabindex, onXXX).
   --  ------------------------------
   procedure Set_Interactive_Attributes (Names : in out Util.Strings.String_Set.Set) is
   begin
      Names.Insert (ACCESS_KEY_ATTR'Access);
      Names.Insert (TABINDEX_ATTR'Access);
   end Set_Interactive_Attributes;

end ASF.Components.Html;

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

   use EL.Objects;

   TITLE_ATTR         : aliased constant String := "title";
   STYLE_ATTR         : aliased constant String := "style";
   STYLE_CLASS_ATTR   : aliased constant String := "styleClass";
   DIR_ATTR           : aliased constant String := "dir";
   LANG_ATTR          : aliased constant String := "lang";

   ACCESS_KEY_ATTR    : aliased constant String := "accesskey";
   ON_BLUR_ATTR       : aliased constant String := "onblur";
   ON_CLICK_ATTR      : aliased constant String := "onclick";
   ON_DBLCLICK_ATTR   : aliased constant String := "ondblclick";
   ON_FOCUS_ATTR      : aliased constant String := "onfocus";
   ON_KEYDOWN_ATTR    : aliased constant String := "onkeydown";
   ON_KEYUP_ATTR      : aliased constant String := "onkeyup";
   ON_MOUSE_DOWN_ATTR : aliased constant String := "onmousedown";
   ON_MOUSE_MOVE_ATTR : aliased constant String := "onmousemove";
   ON_MOUSE_OUT_ATTR  : aliased constant String := "onmouseout";
   ON_MOUSE_OVER_ATTR : aliased constant String := "onmouseover";
   ON_MOUSE_UP_ATTR   : aliased constant String := "onmouseup";

   TABINDEX_ATTR      : aliased constant String := "tabindex";

   procedure Render_Attributes (UI      : in UIHtmlComponent;
                                Context : in out Faces_Context'Class;
                                Writer  : in ResponseWriter_Access) is
      Style  : constant Object := UI.Get_Attribute (Context, "style");
      Class  : constant Object := UI.Get_Attribute (Context, "styleClass");
      Title  : constant Object := UI.Get_Attribute (Context, "title");
   begin
      Writer.Write_Attribute ("id", UI.Get_Client_Id);
      if not Is_Null (Class) then
         Writer.Write_Attribute ("class", Class);
      end if;
      if not Is_Null (Style) then
         Writer.Write_Attribute ("style", Style);
      end if;
      if not Is_Null (Title) then
         Writer.Write_Attribute ("title", Title);
      end if;
   end Render_Attributes;

   --  ------------------------------
   --  Render the attributes which are defined on the component and which are
   --  in the list specified by names.
   --  ------------------------------
   procedure Render_Attributes (UI      : in UIHtmlComponent;
                                Context : in out Faces_Context'Class;
                                Names   : in Util.Strings.String_Set.Set;
                                Writer  : in ResponseWriter_Access) is

      procedure Process_Attribute (Name : in String;
                                   Attr : in UIAttribute) is
      begin
         if Names.Contains (Name'Unrestricted_Access) then
            declare
               Value : constant Object := Get_Value (Attr, UI);
            begin
               if Name = "styleClass" then
                  Writer.Write_Attribute ("class", Value);
               else
                  Writer.Write_Attribute (Name, Value);
               end if;
            end;
         end if;
      end Process_Attribute;

      procedure Write_Attributes is new Iterate_Attributes (Process_Attribute);

      Id : constant Unbounded_String := UI.Get_Client_Id;
   begin
      if Length (Id) > 0 then
         Writer.Write_Attribute ("id", UI.Get_Client_Id);
      end if;
      Write_Attributes (UI);
   end Render_Attributes;

   --  ------------------------------
   --  Add in the names set, the basic text attributes that can be set
   --  on HTML elements (dir, lang, style, title).
   --  ------------------------------
   procedure Set_Text_Attributes (Names : in out Util.Strings.String_Set.Set) is
   begin
      Names.Insert (STYLE_CLASS_ATTR'Access);
      Names.Insert (TITLE_ATTR'Access);
      Names.Insert (DIR_ATTR'Access);
      Names.Insert (LANG_ATTR'Access);
      Names.Insert (STYLE_ATTR'Access);
   end Set_Text_Attributes;

   --  ------------------------------
   --  Add in the names set, the onXXX attributes that can be set
   --  on HTML elements (accesskey, tabindex, onXXX).
   --  ------------------------------
   procedure Set_Interactive_Attributes (Names : in out Util.Strings.String_Set.Set) is
   begin
      Names.Insert (ACCESS_KEY_ATTR'Access);
      Names.Insert (TABINDEX_ATTR'Access);
      Names.Insert (ON_BLUR_ATTR'Access);
      Names.Insert (ON_MOUSE_UP_ATTR'Access);
      Names.Insert (ON_MOUSE_OVER_ATTR'Access);
      Names.Insert (ON_MOUSE_OUT_ATTR'Access);
      Names.Insert (ON_MOUSE_MOVE_ATTR'Access);
      Names.Insert (ON_MOUSE_DOWN_ATTR'Access);
      Names.Insert (ON_KEYUP_ATTR'Access);
      Names.Insert (ON_KEYDOWN_ATTR'Access);
      Names.Insert (ON_FOCUS_ATTR'Access);
      Names.Insert (ON_DBLCLICK_ATTR'Access);
      Names.Insert (ON_CLICK_ATTR'Access);
   end Set_Interactive_Attributes;

end ASF.Components.Html;

Update the definition of interative attributes.


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

with GNAT.Command_Line;

with Readline;

with Util.Strings;
with Util.Properties;
with Util.Log.Loggers;

with MAT.Commands;
with MAT.Interrupts;
with MAT.Targets.Probes;
package body MAT.Targets is

   procedure Free is
     new Ada.Unchecked_Deallocation (MAT.Events.Targets.Target_Events'Class,
                                     MAT.Events.Targets.Target_Events_Access);

   procedure Free is
     new Ada.Unchecked_Deallocation (MAT.Frames.Targets.Target_Frames'Class,
                                     MAT.Frames.Targets.Target_Frames_Access);

   procedure Free is
     new Ada.Unchecked_Deallocation (Target_Process_Type'Class,
                                     Target_Process_Type_Access);

   --  Configure the log managers used by mat.
   procedure Initialize_Logs (Path : in String);

   --  ------------------------------
   --  Release the target process instance.
   --  ------------------------------
   overriding
   procedure Finalize (Target : in out Target_Process_Type) is
   begin
      Free (Target.Events);
      Free (Target.Frames);
   end Finalize;

   --  ------------------------------
   --  Find the region that matches the given name.
   --  ------------------------------
   overriding
   function Find_Region (Resolver : in Target_Process_Type;
                         Name     : in String) return MAT.Memory.Region_Info is
   begin
      return Resolver.Memory.Find_Region (Name);
   end Find_Region;

   --  ------------------------------
   --  Find the symbol in the symbol table and return the start and end address.
   --  ------------------------------
   overriding
   function Find_Symbol (Resolver : in Target_Process_Type;
                         Name     : in String) return MAT.Memory.Region_Info is
      Region : MAT.Memory.Region_Info;
   begin
      if Resolver.Symbols.Is_Null then
         raise MAT.Memory.Targets.Not_Found;
      end if;
      Resolver.Symbols.Value.Find_Symbol_Range (Name, Region.Start_Addr, Region.End_Addr);
      return Region;
   end Find_Symbol;

   --  ------------------------------
   --  Get the start time for the tick reference.
   --  ------------------------------
   overriding
   function Get_Start_Time (Resolver : in Target_Process_Type)
                            return MAT.Types.Target_Tick_Ref is
      Start  : MAT.Types.Target_Tick_Ref;
      Finish : MAT.Types.Target_Tick_Ref;
   begin
      Resolver.Events.Get_Time_Range (Start, Finish);
      return Start;
   end Get_Start_Time;

   --  ------------------------------
   --  Get the console instance.
   --  ------------------------------
   function Console (Target : in Target_Type) return MAT.Consoles.Console_Access is
   begin
      return Target.Console;
   end Console;

   --  ------------------------------
   --  Set the console instance.
   --  ------------------------------
   procedure Console (Target  : in out Target_Type;
                      Console : in MAT.Consoles.Console_Access) is
   begin
      Target.Console := Console;
   end Console;

   --  ------------------------------
   --  Get the current process instance.
   --  ------------------------------
   function Process (Target : in Target_Type) return Target_Process_Type_Access is
   begin
      return Target.Current;
   end Process;

   --  ------------------------------
   --  Initialize the target object to manage the memory slots, the stack frames
   --  and setup the reader to analyze the memory and other events.
   --  ------------------------------
   procedure Initialize (Target : in out Target_Type;
                         Reader : in out MAT.Events.Probes.Probe_Manager_Type'Class) is
   begin
      MAT.Targets.Probes.Initialize (Target  => Target,
                                     Manager => Reader);
   end Initialize;

   --  ------------------------------
   --  Create a process instance to hold and keep track of memory and other information about
   --  the given process ID.
   --  ------------------------------
   procedure Create_Process (Target  : in out Target_Type;
                             Pid     : in MAT.Types.Target_Process_Ref;
                             Path    : in Ada.Strings.Unbounded.Unbounded_String;
                             Process : out Target_Process_Type_Access) is
      Path_String : constant String := Ada.Strings.Unbounded.To_String (Path);
   begin
      Process := Target.Find_Process (Pid);
      if Process = null then
         Process := new Target_Process_Type;
         Process.Pid := Pid;
         Process.Path := Path;
         Process.Symbols := MAT.Symbols.Targets.Target_Symbols_Refs.Create;
         Process.Symbols.Value.Console := Target.Console;
         Process.Symbols.Value.Search_Path := Target.Options.Search_Path;
         Target.Processes.Insert (Pid, Process);
         Target.Console.Notice (MAT.Consoles.N_PID_INFO,
                                "Process" & MAT.Types.Target_Process_Ref'Image (Pid) & " created");
         Target.Console.Notice (MAT.Consoles.N_PATH_INFO,
                                "Path " & Path_String);
      end if;
      if Target.Current = null then
         Target.Current := Process;
      end if;
   end Create_Process;

   --  ------------------------------
   --  Find the process instance from the process ID.
   --  ------------------------------
   function Find_Process (Target : in Target_Type;
                          Pid    : in MAT.Types.Target_Process_Ref)
                          return Target_Process_Type_Access is
      Pos : constant Process_Cursor := Target.Processes.Find (Pid);
   begin
      if Process_Maps.Has_Element (Pos) then
         return Process_Maps.Element (Pos);
      else
         return null;
      end if;
   end Find_Process;

   --  ------------------------------
   --  Iterate over the list of connected processes and execute the <tt>Process</tt> procedure.
   --  ------------------------------
   procedure Iterator (Target  : in Target_Type;
                       Process : access procedure (Proc : in Target_Process_Type'Class)) is
      Iter : Process_Cursor := Target.Processes.First;
   begin
      while Process_Maps.Has_Element (Iter) loop
         Process (Process_Maps.Element (Iter).all);
         Process_Maps.Next (Iter);
      end loop;
   end Iterator;

   --  ------------------------------
   --  Convert the string to a socket address.  The string can have two forms:
   --     port
   --     host:port
   --  ------------------------------
   function To_Sock_Addr_Type (Param : in String) return GNAT.Sockets.Sock_Addr_Type is
      Pos    : constant Natural := Util.Strings.Index (Param, ':');
      Result : GNAT.Sockets.Sock_Addr_Type;
   begin
      if Pos > 0 then
         Result.Port := GNAT.Sockets.Port_Type'Value (Param (Pos + 1 .. Param'Last));
         Result.Addr := GNAT.Sockets.Inet_Addr (Param (Param'First .. Pos - 1));
      else
         Result.Port := GNAT.Sockets.Port_Type'Value (Param);
         Result.Addr := GNAT.Sockets.Any_Inet_Addr;
      end if;
      return Result;
   end To_Sock_Addr_Type;

   --  ------------------------------
   --  Print the application usage.
   --  ------------------------------
   procedure Usage is
      use Ada.Text_IO;
   begin
      Put_Line ("Usage: mat [-i] [-e] [-nw] [-ns] [-b [ip:]port] [-d path] [file.mat]");
      Put_Line ("-i            Enable the interactive mode");
      Put_Line ("-e            Print the probe events as they are received");
      Put_Line ("-nw           Disable the graphical mode");
      Put_Line ("-b [ip:]port  Define the port and local address to bind");
      Put_Line ("-ns           Disable the automatic symbols loading");
      Put_Line ("-d path       Search path to find shared libraries and load their symbols");
      Ada.Command_Line.Set_Exit_Status (2);
      raise Usage_Error;
   end Usage;

   --  ------------------------------
   --  Add a search path for the library and symbol loader.
   --  ------------------------------
   procedure Add_Search_Path (Target : in out MAT.Targets.Target_Type;
                              Path   : in String) is
   begin
      if Ada.Strings.Unbounded.Length (Target.Options.Search_Path) > 0 then
         Ada.Strings.Unbounded.Append (Target.Options.Search_Path, ";");
         Ada.Strings.Unbounded.Append (Target.Options.Search_Path, Path);
      else
         Target.Options.Search_Path := Ada.Strings.Unbounded.To_Unbounded_String (Path);
      end if;
   end Add_Search_Path;

   --  ------------------------------
   --  Configure the log managers used by mat.
   --  ------------------------------
   procedure Initialize_Logs (Path : in String) is
      Props : Util.Properties.Manager;
   begin
      begin
         Props.Load_Properties (Path);

      exception
         when Ada.IO_Exceptions.Name_Error =>
            --  Default log configuration.
            Props.Set ("log4j.rootCategory", "INFO,console,mat");
            Props.Set ("log4j.appender.console", "Console");
            Props.Set ("log4j.appender.console.level", "WARN");
            Props.Set ("log4j.appender.console.layout", "level-message");
            Props.Set ("log4j.appender.mat", "File");
            Props.Set ("log4j.appender.mat.File", "mat.log");
      end;
      Util.Log.Loggers.Initialize (Props);
   end Initialize_Logs;

   --  ------------------------------
   --  Parse the command line arguments and configure the target instance.
   --  ------------------------------
   procedure Initialize_Options (Target  : in out MAT.Targets.Target_Type) is
   begin
      Initialize_Logs ("matp.properties");
      GNAT.Command_Line.Initialize_Option_Scan (Stop_At_First_Non_Switch => True,
                                                Section_Delimiters       => "targs");
      loop
         case GNAT.Command_Line.Getopt ("i e nw ns b: d:") is
            when ASCII.NUL =>
               exit;

            when 'i' =>
               Target.Options.Interactive := True;

            when 'e' =>
               Target.Options.Print_Events := True;

            when 'b' =>
               Target.Options.Server_Mode := True;
               Target.Options.Address := To_Sock_Addr_Type (GNAT.Command_Line.Parameter);

            when 'n' =>
               if GNAT.Command_Line.Full_Switch = "nw" then
                  Target.Options.Graphical := False;
               else
                  Target.Options.Load_Symbols := False;
               end if;

            when 'd' =>
               Add_Search_Path (Target, GNAT.Command_Line.Parameter);

            when '*' =>
               exit;

            when others =>
               Usage;

         end case;
      end loop;

   exception
      when Usage_Error =>
         raise;

      when others =>
         Usage;

   end Initialize_Options;

   --  ------------------------------
   --  Enter in the interactive loop reading the commands from the standard input
   --  and executing the commands.
   --  ------------------------------
   procedure Interactive (Target : in out MAT.Targets.Target_Type) is
   begin
      MAT.Interrupts.Install;
      loop
         declare
            Line : constant String := Readline.Get_Line ("mat>");
         begin
            MAT.Interrupts.Clear;
            MAT.Commands.Execute (Target, Line);

         exception
            when MAT.Commands.Stop_Interp =>
               exit;
         end;
      end loop;
   end Interactive;

   --  ------------------------------
   --  Start the server to listen to MAT event socket streams.
   --  ------------------------------
   procedure Start (Target : in out Target_Type) is
   begin
      if Target.Options.Server_Mode then
         Target.Server.Start (Target'Unchecked_Access, Target.Options.Address);
      end if;
   end Start;

   --  ------------------------------
   --  Stop the server thread.
   --  ------------------------------
   procedure Stop (Target : in out Target_Type) is
   begin
      if Target.Options.Server_Mode then
         Target.Server.Stop;
      end if;
   end Stop;

   --  ------------------------------
   --  Release the storage used by the target object.
   --  ------------------------------
   overriding
   procedure Finalize (Target : in out Target_Type) is
   begin
      while not Target.Processes.Is_Empty loop
         declare
            Process : Target_Process_Type_Access := Target.Processes.First_Element;
         begin
            Free (Process);
            Target.Processes.Delete_First;
         end;
      end loop;
   end Finalize;

end MAT.Targets;

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

with GNAT.Command_Line;

with Readline;

with Util.Strings;
with Util.Properties;
with Util.Log.Loggers;

with MAT.Commands;
with MAT.Interrupts;
with MAT.Targets.Probes;
package body MAT.Targets is

   procedure Free is
     new Ada.Unchecked_Deallocation (MAT.Events.Targets.Target_Events'Class,
                                     MAT.Events.Targets.Target_Events_Access);

   procedure Free is
     new Ada.Unchecked_Deallocation (MAT.Frames.Targets.Target_Frames'Class,
                                     MAT.Frames.Targets.Target_Frames_Access);

   procedure Free is
     new Ada.Unchecked_Deallocation (Target_Process_Type'Class,
                                     Target_Process_Type_Access);

   --  Configure the log managers used by mat.
   procedure Initialize_Logs (Path : in String);

   --  ------------------------------
   --  Release the target process instance.
   --  ------------------------------
   overriding
   procedure Finalize (Target : in out Target_Process_Type) is
   begin
      Free (Target.Events);
      Free (Target.Frames);
   end Finalize;

   --  ------------------------------
   --  Find the region that matches the given name.
   --  ------------------------------
   overriding
   function Find_Region (Resolver : in Target_Process_Type;
                         Name     : in String) return MAT.Memory.Region_Info is
   begin
      return Resolver.Memory.Find_Region (Name);
   end Find_Region;

   --  ------------------------------
   --  Find the symbol in the symbol table and return the start and end address.
   --  ------------------------------
   overriding
   function Find_Symbol (Resolver : in Target_Process_Type;
                         Name     : in String) return MAT.Memory.Region_Info is
      Region : MAT.Memory.Region_Info;
   begin
      if Resolver.Symbols.Is_Null then
         raise MAT.Memory.Targets.Not_Found;
      end if;
      Resolver.Symbols.Value.Find_Symbol_Range (Name, Region.Start_Addr, Region.End_Addr);
      return Region;
   end Find_Symbol;

   --  ------------------------------
   --  Get the start time for the tick reference.
   --  ------------------------------
   overriding
   function Get_Start_Time (Resolver : in Target_Process_Type)
                            return MAT.Types.Target_Tick_Ref is
      Start  : MAT.Types.Target_Tick_Ref;
      Finish : MAT.Types.Target_Tick_Ref;
   begin
      Resolver.Events.Get_Time_Range (Start, Finish);
      return Start;
   end Get_Start_Time;

   --  ------------------------------
   --  Get the console instance.
   --  ------------------------------
   function Console (Target : in Target_Type) return MAT.Consoles.Console_Access is
   begin
      return Target.Console;
   end Console;

   --  ------------------------------
   --  Set the console instance.
   --  ------------------------------
   procedure Console (Target  : in out Target_Type;
                      Console : in MAT.Consoles.Console_Access) is
   begin
      Target.Console := Console;
   end Console;

   --  ------------------------------
   --  Get the current process instance.
   --  ------------------------------
   function Process (Target : in Target_Type) return Target_Process_Type_Access is
   begin
      return Target.Current;
   end Process;

   --  ------------------------------
   --  Initialize the target object to manage the memory slots, the stack frames
   --  and setup the reader to analyze the memory and other events.
   --  ------------------------------
   procedure Initialize (Target : in out Target_Type;
                         Reader : in out MAT.Events.Probes.Probe_Manager_Type'Class) is
   begin
      MAT.Targets.Probes.Initialize (Target  => Target,
                                     Manager => Reader);
   end Initialize;

   --  ------------------------------
   --  Create a process instance to hold and keep track of memory and other information about
   --  the given process ID.
   --  ------------------------------
   procedure Create_Process (Target  : in out Target_Type;
                             Pid     : in MAT.Types.Target_Process_Ref;
                             Path    : in Ada.Strings.Unbounded.Unbounded_String;
                             Process : out Target_Process_Type_Access) is
      Path_String : constant String := Ada.Strings.Unbounded.To_String (Path);
   begin
      Process := Target.Find_Process (Pid);
      if Process = null then
         Process := new Target_Process_Type;
         Process.Pid := Pid;
         Process.Path := Path;
         Process.Symbols := MAT.Symbols.Targets.Target_Symbols_Refs.Create;
         Process.Symbols.Value.Console := Target.Console;
         Process.Symbols.Value.Search_Path := Target.Options.Search_Path;
         Target.Processes.Insert (Pid, Process);
         Target.Console.Notice (MAT.Consoles.N_PID_INFO,
                                "Process" & MAT.Types.Target_Process_Ref'Image (Pid) & " created");
         Target.Console.Notice (MAT.Consoles.N_PATH_INFO,
                                "Path " & Path_String);
      end if;
      if Target.Current = null then
         Target.Current := Process;
      end if;
   end Create_Process;

   --  ------------------------------
   --  Find the process instance from the process ID.
   --  ------------------------------
   function Find_Process (Target : in Target_Type;
                          Pid    : in MAT.Types.Target_Process_Ref)
                          return Target_Process_Type_Access is
      Pos : constant Process_Cursor := Target.Processes.Find (Pid);
   begin
      if Process_Maps.Has_Element (Pos) then
         return Process_Maps.Element (Pos);
      else
         return null;
      end if;
   end Find_Process;

   --  ------------------------------
   --  Iterate over the list of connected processes and execute the <tt>Process</tt> procedure.
   --  ------------------------------
   procedure Iterator (Target  : in Target_Type;
                       Process : access procedure (Proc : in Target_Process_Type'Class)) is
      Iter : Process_Cursor := Target.Processes.First;
   begin
      while Process_Maps.Has_Element (Iter) loop
         Process (Process_Maps.Element (Iter).all);
         Process_Maps.Next (Iter);
      end loop;
   end Iterator;

   --  ------------------------------
   --  Convert the string to a socket address.  The string can have two forms:
   --     port
   --     host:port
   --  ------------------------------
   function To_Sock_Addr_Type (Param : in String) return GNAT.Sockets.Sock_Addr_Type is
      Pos    : constant Natural := Util.Strings.Index (Param, ':');
      Result : GNAT.Sockets.Sock_Addr_Type;
   begin
      if Pos > 0 then
         Result.Port := GNAT.Sockets.Port_Type'Value (Param (Pos + 1 .. Param'Last));
         Result.Addr := GNAT.Sockets.Inet_Addr (Param (Param'First .. Pos - 1));
      else
         Result.Port := GNAT.Sockets.Port_Type'Value (Param);
         Result.Addr := GNAT.Sockets.Any_Inet_Addr;
      end if;
      return Result;
   end To_Sock_Addr_Type;

   --  ------------------------------
   --  Print the application usage.
   --  ------------------------------
   procedure Usage is
      use Ada.Text_IO;
   begin
      Put_Line ("Usage: mat [-i] [-e] [-nw] [-ns] [-s] [-b [ip:]port] [-d path] [file.mat]");
      Put_Line ("-i            Enable the interactive mode");
      Put_Line ("-e            Print the probe events as they are received");
      Put_Line ("-nw           Disable the graphical mode");
      Put_Line ("-s            Start the TCP/IP server to receive events");
      Put_Line ("-b [ip:]port  Define the port and local address to bind");
      Put_Line ("-ns           Disable the automatic symbols loading");
      Put_Line ("-d path       Search path to find shared libraries and load their symbols");
      Ada.Command_Line.Set_Exit_Status (2);
      raise Usage_Error;
   end Usage;

   --  ------------------------------
   --  Add a search path for the library and symbol loader.
   --  ------------------------------
   procedure Add_Search_Path (Target : in out MAT.Targets.Target_Type;
                              Path   : in String) is
   begin
      if Ada.Strings.Unbounded.Length (Target.Options.Search_Path) > 0 then
         Ada.Strings.Unbounded.Append (Target.Options.Search_Path, ";");
         Ada.Strings.Unbounded.Append (Target.Options.Search_Path, Path);
      else
         Target.Options.Search_Path := Ada.Strings.Unbounded.To_Unbounded_String (Path);
      end if;
   end Add_Search_Path;

   --  ------------------------------
   --  Configure the log managers used by mat.
   --  ------------------------------
   procedure Initialize_Logs (Path : in String) is
      Props : Util.Properties.Manager;
   begin
      begin
         Props.Load_Properties (Path);

      exception
         when Ada.IO_Exceptions.Name_Error =>
            --  Default log configuration.
            Props.Set ("log4j.rootCategory", "INFO,console,mat");
            Props.Set ("log4j.appender.console", "Console");
            Props.Set ("log4j.appender.console.level", "WARN");
            Props.Set ("log4j.appender.console.layout", "level-message");
            Props.Set ("log4j.appender.mat", "File");
            Props.Set ("log4j.appender.mat.File", "mat.log");
      end;
      Util.Log.Loggers.Initialize (Props);
   end Initialize_Logs;

   --  ------------------------------
   --  Parse the command line arguments and configure the target instance.
   --  ------------------------------
   procedure Initialize_Options (Target  : in out MAT.Targets.Target_Type) is
   begin
      Initialize_Logs ("matp.properties");
      GNAT.Command_Line.Initialize_Option_Scan (Stop_At_First_Non_Switch => True,
                                                Section_Delimiters       => "targs");
      loop
         case GNAT.Command_Line.Getopt ("i e s nw ns b: d:") is
            when ASCII.NUL =>
               exit;

            when 'i' =>
               Target.Options.Interactive := True;

            when 'e' =>
               Target.Options.Print_Events := True;

            when 's' =>
               Target.Options.Server_Mode := True;

            when 'b' =>
               Target.Options.Server_Mode := True;
               Target.Options.Address := To_Sock_Addr_Type (GNAT.Command_Line.Parameter);

            when 'n' =>
               if GNAT.Command_Line.Full_Switch = "nw" then
                  Target.Options.Graphical := False;
               else
                  Target.Options.Load_Symbols := False;
               end if;

            when 'd' =>
               Add_Search_Path (Target, GNAT.Command_Line.Parameter);

            when '*' =>
               exit;

            when others =>
               Usage;

         end case;
      end loop;

   exception
      when Usage_Error =>
         raise;

      when others =>
         Usage;

   end Initialize_Options;

   --  ------------------------------
   --  Enter in the interactive loop reading the commands from the standard input
   --  and executing the commands.
   --  ------------------------------
   procedure Interactive (Target : in out MAT.Targets.Target_Type) is
   begin
      MAT.Interrupts.Install;
      loop
         declare
            Line : constant String := Readline.Get_Line ("mat>");
         begin
            MAT.Interrupts.Clear;
            MAT.Commands.Execute (Target, Line);

         exception
            when MAT.Commands.Stop_Interp =>
               exit;
         end;
      end loop;
   end Interactive;

   --  ------------------------------
   --  Start the server to listen to MAT event socket streams.
   --  ------------------------------
   procedure Start (Target : in out Target_Type) is
   begin
      if Target.Options.Server_Mode then
         Target.Server.Start (Target'Unchecked_Access, Target.Options.Address);
      end if;
   end Start;

   --  ------------------------------
   --  Stop the server thread.
   --  ------------------------------
   procedure Stop (Target : in out Target_Type) is
   begin
      if Target.Options.Server_Mode then
         Target.Server.Stop;
      end if;
   end Stop;

   --  ------------------------------
   --  Release the storage used by the target object.
   --  ------------------------------
   overriding
   procedure Finalize (Target : in out Target_Type) is
   begin
      while not Target.Processes.Is_Empty loop
         declare
            Process : Target_Process_Type_Access := Target.Processes.First_Element;
         begin
            Free (Process);
            Target.Processes.Delete_First;
         end;
      end loop;
   end Finalize;

end MAT.Targets;

Add the -s option to start the TCP/IP server


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

package body Natools.S_Expressions.Atom_Buffers is

   procedure Preallocate (Buffer : in out Atom_Buffer; Length : in Count) is
      Old_Size, New_Size : Count := 0;
   begin
      if Buffer.Used + Length <= Buffer.Available then
         return;
      end if;

      Old_Size := Buffer.Available;
      New_Size := Buffer.Used + Length;

      if Buffer.Ref.Is_Empty then
         declare
            function Create return Atom;

            function Create return Atom is
            begin
               return Atom'(1 .. New_Size => <>);
            end Create;
         begin
            Buffer.Ref.Replace (Create'Access);
         end;
      else
         declare
            function Create return Atom;

            Old_Accessor : constant Atom_Refs.Accessor := Buffer.Ref.Query;

            function Create return Atom is
            begin
               return Result : Atom (1 .. New_Size) do
                  Result (1 .. Old_Size) := Old_Accessor.Data.all;
               end return;
            end Create;
         begin
            Buffer.Ref.Replace (Create'Access);
         end;
      end if;

      Buffer.Available := New_Size;
   end Preallocate;

   procedure Append (Buffer : in out Atom_Buffer; Data : in Atom) is
   begin
      if Data'Length > 0 then
         Preallocate (Buffer, Data'Length);
         Buffer.Ref.Update.Data.all
           (Buffer.Used + 1 .. Buffer.Used + Data'Length)
           := Data;
         Buffer.Used := Buffer.Used + Data'Length;
      end if;
   end Append;

   procedure Append (Buffer : in out Atom_Buffer; Data : in Octet) is
   begin
      Preallocate (Buffer, 1);
      Buffer.Ref.Update.Data.all (Buffer.Used + 1) := Data;
      Buffer.Used := Buffer.Used + 1;
   end Append;

   procedure Append_Reverse (Buffer : in out Atom_Buffer; Data : in Atom) is
      procedure Process (Target : in out Atom);

      procedure Process (Target : in out Atom) is
      begin
         for I in reverse Data'Range loop
            Buffer.Used := Buffer.Used + 1;
            Target (Buffer.Used) := Data (I);
         end loop;
      end Process;
   begin
      Preallocate (Buffer, Data'Length);
      Buffer.Ref.Update (Process'Access);
   end Append_Reverse;

   procedure Invert (Buffer : in out Atom_Buffer) is
      procedure Process (Data : in out Atom);

      procedure Process (Data : in out Atom) is
         Low : Count := Data'First;
         High : Count := Buffer.Used;
         Tmp : Octet;
      begin
         while Low < High loop
            Tmp := Data (Low);
            Data (Low) := Data (High);
            Data (High) := Tmp;
            Low := Low + 1;
            High := High - 1;
         end loop;
      end Process;
   begin
      if not Buffer.Ref.Is_Empty then
         Buffer.Ref.Update (Process'Access);
      end if;
   end Invert;

   function Length (Buffer : Atom_Buffer) return Count is
   begin
      return Buffer.Used;
   end Length;

   function Capacity (Buffer : Atom_Buffer) return Count is
   begin
      return Buffer.Available;
   end Capacity;

   function Data (Buffer : Atom_Buffer) return Atom is
   begin
      if Buffer.Ref.Is_Empty then
         pragma Assert (Buffer.Available = 0 and Buffer.Used = 0);
         return Null_Atom;
      else
         return Buffer.Ref.Query.Data.all (1 .. Buffer.Used);
      end if;
   end Data;

   function Raw_Query (Buffer : Atom_Buffer) return Atom_Refs.Accessor is
      function Create return Atom;

      function Create return Atom is
      begin
         return Null_Atom;
      end Create;
   begin
      if Buffer.Ref.Is_Empty then
         declare
            Tmp_Ref : constant Atom_Refs.Reference
              := Atom_Refs.Create (Create'Access);
         begin
            return Tmp_Ref.Query;
         end;
      else
         return Buffer.Ref.Query;
      end if;
   end Raw_Query;

   procedure Query
     (Buffer : in Atom_Buffer;
      Process : not null access procedure (Data : in Atom)) is
   begin
      if Buffer.Ref.Is_Empty then
         Process.all (Null_Atom);
      else
         Process.all (Buffer.Ref.Query.Data.all (1 .. Buffer.Used));
      end if;
   end Query;

   procedure Peek
     (Buffer : in Atom_Buffer;
      Data : out Atom;
      Length : out Count)
   is
      Transmit : constant Count := Count'Min (Data'Length, Buffer.Used);
   begin
      Length := Buffer.Used;

      if Buffer.Ref.Is_Empty then
         pragma Assert (Length = 0);
         null;
      else
         Data (Data'First .. Data'First + Transmit - 1)
           := Buffer.Ref.Query.Data.all (1 .. Transmit);
      end if;
   end Peek;

   function Element (Buffer : Atom_Buffer; Position : Count) return Octet is
   begin
      return Buffer.Ref.Query.Data.all (Position);
   end Element;

   procedure Pop (Buffer : in out Atom_Buffer; Data : out Octet) is
   begin
      Data := Buffer.Ref.Query.Data.all (Buffer.Used);
      Buffer.Used := Buffer.Used - 1;
   end Pop;

   procedure Hard_Reset (Buffer : in out Atom_Buffer) is
   begin
      Buffer.Ref.Reset;
      Buffer.Available := 0;
      Buffer.Used := 0;
   end Hard_Reset;

   procedure Soft_Reset (Buffer : in out Atom_Buffer) is
   begin
      Buffer.Used := 0;
   end Soft_Reset;

   overriding procedure Write
     (Buffer : in out Atom_Buffer;
      Item : in Ada.Streams.Stream_Element_Array)
     renames Append;

   overriding procedure Read
     (Buffer : in out Atom_Buffer;
      Item : out Ada.Streams.Stream_Element_Array;
      Last : out Ada.Streams.Stream_Element_Offset) is
   begin
      if Item'Length < Buffer.Used then
         Last := Item'Last;
         Item := Buffer.Ref.Query.Data.all (1 .. Item'Length);
         Buffer.Used := Buffer.Used - Item'Length;
      else
         Last := Item'First + Buffer.Used - 1;
         Item (Item'First .. Last)
           := Buffer.Ref.Query.Data.all (1 .. Buffer.Used);
         Buffer.Used := 0;
      end if;
   end Read;

end Natools.S_Expressions.Atom_Buffers;

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

package body Natools.S_Expressions.Atom_Buffers is

   procedure Preallocate (Buffer : in out Atom_Buffer; Length : in Count) is
      Old_Size, New_Size : Count := 0;
   begin
      if Buffer.Used + Length <= Buffer.Available then
         return;
      end if;

      Old_Size := Buffer.Available;
      New_Size := Buffer.Used + Length;

      if Buffer.Ref.Is_Empty then
         declare
            function Create return Atom;

            function Create return Atom is
            begin
               return Atom'(1 .. New_Size => <>);
            end Create;
         begin
            Buffer.Ref.Replace (Create'Access);
         end;
      else
         declare
            function Create return Atom;

            Old_Accessor : constant Atom_Refs.Accessor := Buffer.Ref.Query;

            function Create return Atom is
            begin
               return Result : Atom (1 .. New_Size) do
                  Result (1 .. Old_Size) := Old_Accessor.Data.all;
               end return;
            end Create;
         begin
            Buffer.Ref.Replace (Create'Access);
         end;
      end if;

      Buffer.Available := New_Size;
   end Preallocate;

   procedure Append (Buffer : in out Atom_Buffer; Data : in Atom) is
   begin
      if Data'Length > 0 then
         Preallocate (Buffer, Data'Length);
         Buffer.Ref.Update.Data.all
           (Buffer.Used + 1 .. Buffer.Used + Data'Length)
           := Data;
         Buffer.Used := Buffer.Used + Data'Length;
      end if;
   end Append;

   procedure Append (Buffer : in out Atom_Buffer; Data : in Octet) is
   begin
      Preallocate (Buffer, 1);
      Buffer.Ref.Update.Data.all (Buffer.Used + 1) := Data;
      Buffer.Used := Buffer.Used + 1;
   end Append;

   procedure Append_Reverse (Buffer : in out Atom_Buffer; Data : in Atom) is
      procedure Process (Target : in out Atom);

      procedure Process (Target : in out Atom) is
      begin
         for I in reverse Data'Range loop
            Buffer.Used := Buffer.Used + 1;
            Target (Buffer.Used) := Data (I);
         end loop;
      end Process;
   begin
      Preallocate (Buffer, Data'Length);
      Buffer.Ref.Update (Process'Access);
   end Append_Reverse;

   procedure Invert (Buffer : in out Atom_Buffer) is
      procedure Process (Data : in out Atom);

      procedure Process (Data : in out Atom) is
         Low : Count := Data'First;
         High : Count := Buffer.Used;
         Tmp : Octet;
      begin
         while Low < High loop
            Tmp := Data (Low);
            Data (Low) := Data (High);
            Data (High) := Tmp;
            Low := Low + 1;
            High := High - 1;
         end loop;
      end Process;
   begin
      if not Buffer.Ref.Is_Empty then
         Buffer.Ref.Update (Process'Access);
      end if;
   end Invert;

   function Length (Buffer : Atom_Buffer) return Count is
   begin
      return Buffer.Used;
   end Length;

   function Capacity (Buffer : Atom_Buffer) return Count is
   begin
      return Buffer.Available;
   end Capacity;

   function Data (Buffer : Atom_Buffer) return Atom is
   begin
      if Buffer.Ref.Is_Empty then
         pragma Assert (Buffer.Available = 0 and Buffer.Used = 0);
         return Null_Atom;
      else
         return Buffer.Ref.Query.Data.all (1 .. Buffer.Used);
      end if;
   end Data;

   function Raw_Query (Buffer : Atom_Buffer) return Atom_Refs.Accessor is
      function Create return Atom;

      function Create return Atom is
      begin
         return Null_Atom;
      end Create;
   begin
      if Buffer.Ref.Is_Empty then
         declare
            Tmp_Ref : constant Atom_Refs.Reference
              := Atom_Refs.Create (Create'Access);
         begin
            return Tmp_Ref.Query;
         end;
      else
         return Buffer.Ref.Query;
      end if;
   end Raw_Query;

   procedure Query
     (Buffer : in Atom_Buffer;
      Process : not null access procedure (Data : in Atom)) is
   begin
      if Buffer.Ref.Is_Empty then
         Process.all (Null_Atom);
      else
         Process.all (Buffer.Ref.Query.Data.all (1 .. Buffer.Used));
      end if;
   end Query;

   procedure Peek
     (Buffer : in Atom_Buffer;
      Data : out Atom;
      Length : out Count)
   is
      Transmit : constant Count := Count'Min (Data'Length, Buffer.Used);
   begin
      Length := Buffer.Used;

      if Buffer.Ref.Is_Empty then
         pragma Assert (Length = 0);
         null;
      else
         Data (Data'First .. Data'First + Transmit - 1)
           := Buffer.Ref.Query.Data.all (1 .. Transmit);
      end if;
   end Peek;

   function Element (Buffer : Atom_Buffer; Position : Count) return Octet is
   begin
      return Buffer.Ref.Query.Data.all (Position);
   end Element;

   procedure Pop (Buffer : in out Atom_Buffer; Data : out Octet) is
   begin
      Data := Buffer.Ref.Query.Data.all (Buffer.Used);
      Buffer.Used := Buffer.Used - 1;
   end Pop;

   procedure Hard_Reset (Buffer : in out Atom_Buffer) is
   begin
      Buffer.Ref.Reset;
      Buffer.Available := 0;
      Buffer.Used := 0;
   end Hard_Reset;

   procedure Soft_Reset (Buffer : in out Atom_Buffer) is
   begin
      Buffer.Used := 0;
   end Soft_Reset;

   overriding procedure Write
     (Buffer : in out Atom_Buffer;
      Item : in Ada.Streams.Stream_Element_Array)
     renames Append;

   overriding procedure Read
     (Buffer : in out Atom_Buffer;
      Item : out Ada.Streams.Stream_Element_Array;
      Last : out Ada.Streams.Stream_Element_Offset) is
   begin
      if Item'Length < Buffer.Used then
         declare
            Mutator : constant Atom_Refs.Mutator := Buffer.Ref.Update;
         begin
            Last := Item'Last;
            Item := Mutator.Data.all (1 .. Item'Length);
            Buffer.Used := Buffer.Used - Item'Length;
            Mutator.Data.all (1 .. Buffer.Used) := Mutator.Data.all
              (Item'Length + 1 .. Item'Length + Buffer.Used);
         end;
      else
         Last := Item'First + Buffer.Used - 1;
         Item (Item'First .. Last)
           := Buffer.Ref.Query.Data.all (1 .. Buffer.Used);
         Buffer.Used := 0;
      end if;
   end Read;

end Natools.S_Expressions.Atom_Buffers;

fix stream read

s_expressions-atom_buffers: fix stream read


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

with Util.Tests;
package ADO.Queries.Tests is

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

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

   procedure Test_Load_Queries (T : in out Test);

   --  Test the Initialize operation called several times
   procedure Test_Initialize (T : in out Test);

   --  Test the Set_Query operation.
   procedure Test_Set_Query (T : in out Test);

   --  Test the Set_Limit operation.
   procedure Test_Set_Limit (T : in out Test);

   --  Test the Find_Query operation.
   procedure Test_Find_Query (T : in out Test);

end ADO.Queries.Tests;

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

with Util.Tests;
package ADO.Queries.Tests is

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

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

   procedure Test_Load_Queries (T : in out Test);

   --  Test re-loading queries.
   procedure Test_Reload_Queries (T : in out Test);

   --  Test the Initialize operation called several times
   procedure Test_Initialize (T : in out Test);

   --  Test the Set_Query operation.
   procedure Test_Set_Query (T : in out Test);

   --  Test the Set_Limit operation.
   procedure Test_Set_Limit (T : in out Test);

   --  Test the Find_Query operation.
   procedure Test_Find_Query (T : in out Test);

end ADO.Queries.Tests;

Declare the Test_Reload_Queries procedure


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

with Util.Tests;
package ADO.Queries.Tests is

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

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

   procedure Test_Load_Queries (T : in out Test);

   --  Test re-loading queries.
   procedure Test_Reload_Queries (T : in out Test);

   --  Test the Initialize operation called several times
   procedure Test_Initialize (T : in out Test);

   --  Test the Set_Query operation.
   procedure Test_Set_Query (T : in out Test);

   --  Test the Set_Limit operation.
   procedure Test_Set_Limit (T : in out Test);

   --  Test the Find_Query operation.
   procedure Test_Find_Query (T : in out Test);

end ADO.Queries.Tests;

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

with Util.Tests;
package ADO.Queries.Tests is

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

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

   procedure Test_Load_Queries (T : in out Test);

   --  Test re-loading queries.
   procedure Test_Reload_Queries (T : in out Test);

   --  Test the Initialize operation called several times
   procedure Test_Initialize (T : in out Test);

   --  Test the Set_Query operation.
   procedure Test_Set_Query (T : in out Test);

   --  Test the Set_Limit operation.
   procedure Test_Set_Limit (T : in out Test);

   --  Test the Find_Query operation.
   procedure Test_Find_Query (T : in out Test);

   --  Test the missing query.
   procedure Test_Missing_Query (T : in out Test);

end ADO.Queries.Tests;

Declare Test_Missing_Query procedure to test raising the Query_Error exception


-----------------------------------------------------------------------
--  gen-utils -- Utilities for model generator
--  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 Ada.Strings.Unbounded;
with Ada.Containers.Ordered_Sets;
with Ada.Containers.Indefinite_Vectors;

with DOM.Core;
package Gen.Utils is

   --  Generic procedure to iterate over the DOM nodes children of node
   --  and having the entity name name.
   generic
      type T is limited private;
      with procedure Process (Closure : in out T;
                              Node    : DOM.Core.Node);
   procedure Iterate_Nodes (Closure : in out T;
                            Node    : in DOM.Core.Node;
                            Name    : in String;
                            Recurse : in Boolean := True);

   --  Get the first DOM child from the given entity tag
   function Get_Child (Node : in DOM.Core.Node;
                       Name : in String) return DOM.Core.Node;

   --  Get the content of the node
   function Get_Data_Content (Node : in DOM.Core.Node) return String;

   --  Get the content of the node identified by Name under the given DOM node.
   function Get_Data_Content (Node : in DOM.Core.Node;
                              Name : in String) return String;

   --  Get a boolean attribute
   function Get_Attribute (Node    : in DOM.Core.Node;
                           Name    : in String;
                           Default : in Boolean := False) return Boolean;

   --  Get a string attribute
   function Get_Attribute (Node    : in DOM.Core.Node;
                           Name    : in String;
                           Default : in String := "") return String;

   --  Get the Ada package name from a qualified type
   function Get_Package_Name (Name : in String) return String;

   --  Get the Ada type name from a full qualified type
   function Get_Type_Name (Name : in String) return String;

   --  Get a query name from the XML query file name
   function Get_Query_Name (Path : in String) return String;

   use Ada.Strings.Unbounded;
   package String_Set is
     new Ada.Containers.Ordered_Sets (Element_Type => Ada.Strings.Unbounded.Unbounded_String,
                                      "<"          => Ada.Strings.Unbounded."<",
                                      "="          => Ada.Strings.Unbounded."=");

   package String_List is new Ada.Containers.Indefinite_Vectors (Index_Type   => Positive,
                                                                 Element_Type => String,
                                                                 "="          => "=");

   --  Returns True if the Name is a valid project or module name.
   --  The name must be a valid Ada identifier.
   function Is_Valid_Name (Name : in String) return Boolean;

end Gen.Utils;

-----------------------------------------------------------------------
--  gen-utils -- Utilities for model generator
--  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 Ada.Strings.Unbounded;
with Ada.Containers.Ordered_Sets;
with Ada.Containers.Indefinite_Vectors;

with DOM.Core;
package Gen.Utils is

   --  Generic procedure to iterate over the DOM nodes children of node
   --  and having the entity name name.
   generic
      type T (<>) is limited private;
      with procedure Process (Closure : in out T;
                              Node    : DOM.Core.Node);
   procedure Iterate_Nodes (Closure : in out T;
                            Node    : in DOM.Core.Node;
                            Name    : in String;
                            Recurse : in Boolean := True);

   --  Get the first DOM child from the given entity tag
   function Get_Child (Node : in DOM.Core.Node;
                       Name : in String) return DOM.Core.Node;

   --  Get the content of the node
   function Get_Data_Content (Node : in DOM.Core.Node) return String;

   --  Get the content of the node identified by Name under the given DOM node.
   function Get_Data_Content (Node : in DOM.Core.Node;
                              Name : in String) return String;

   --  Get a boolean attribute
   function Get_Attribute (Node    : in DOM.Core.Node;
                           Name    : in String;
                           Default : in Boolean := False) return Boolean;

   --  Get a string attribute
   function Get_Attribute (Node    : in DOM.Core.Node;
                           Name    : in String;
                           Default : in String := "") return String;

   --  Get the Ada package name from a qualified type
   function Get_Package_Name (Name : in String) return String;

   --  Get the Ada type name from a full qualified type
   function Get_Type_Name (Name : in String) return String;

   --  Get a query name from the XML query file name
   function Get_Query_Name (Path : in String) return String;

   use Ada.Strings.Unbounded;
   package String_Set is
     new Ada.Containers.Ordered_Sets (Element_Type => Ada.Strings.Unbounded.Unbounded_String,
                                      "<"          => Ada.Strings.Unbounded."<",
                                      "="          => Ada.Strings.Unbounded."=");

   package String_List is new Ada.Containers.Indefinite_Vectors (Index_Type   => Positive,
                                                                 Element_Type => String,
                                                                 "="          => "=");

   --  Returns True if the Name is a valid project or module name.
   --  The name must be a valid Ada identifier.
   function Is_Valid_Name (Name : in String) return Boolean;

end Gen.Utils;

Allow to use indefinite types for the generic iterate operation


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

--  The Security.OAuth.Clients package implements the client OAuth 2.0 authorization.
--
--  Note: OAuth 1.0 could be implemented but since it's being deprecated it's not worth doing it.
package Security.OAuth.Clients is

   --  ------------------------------
   --  Access Token
   --  ------------------------------
   --  Access tokens are credentials used to access protected resources.
   --  The access token is represented as a Principal.  This is an opaque
   --  value for an application.
   type Access_Token (Len : Natural) is new Security.Principal with private;
   type Access_Token_Access is access all Access_Token'Class;

   --  Get the principal name.  This is the OAuth access token.
   function Get_Name (From : in Access_Token) return String;

   --  ------------------------------
   --  Application
   --  ------------------------------
   --  The Application holds the necessary information to let a user
   --  grant access to its protected resources on the resource server.  It contains
   --  information that allows the OAuth authorization server to identify the
   --  application (client id and secret key).
   type Application is tagged private;

   --  Get the application identifier.
   function Get_Application_Identifier (App : in Application) return String;

   --  Set the application identifier used by the OAuth authorization server
   --  to identify the application (for example, the App ID in Facebook).
   procedure Set_Application_Identifier (App    : in out Application;
                                         Client : in String);

   --  Set the application secret defined in the OAuth authorization server
   --  for the application (for example, the App Secret in Facebook).
   procedure Set_Application_Secret (App    : in out Application;
                                     Secret : in String);

   --  Set the redirection callback that will be used to redirect the user
   --  back to the application after the OAuth authorization is finished.
   procedure Set_Application_Callback (App : in out Application;
                                       URI : in String);

   --  Set the OAuth authorization server URI that the application must use
   --  to exchange the OAuth code into an access token.
   procedure Set_Provider_URI (App : in out Application;
                               URI : in String);

   --  OAuth 2.0 Section 4.1.1  Authorization Request

   --  Build a unique opaque value used to prevent cross-site request forgery.
   --  The Nonce parameters is an optional but recommended unique value
   --  used only once.  The state value will be returned back by the OAuth provider.
   --  This protects the <tt>client_id</tt> and <tt>redirect_uri</tt> parameters.
   function Get_State (App   : in Application;
                       Nonce : in String) return String;

   --  Get the authenticate parameters to build the URI to redirect the user to
   --  the OAuth authorization form.
   function Get_Auth_Params (App : in Application;
                             State : in String;
                             Scope : in String := "") return String;

   --  OAuth 2.0 Section 4.1.2  Authorization Response

   --  Verify that the State opaque value was created by the Get_State
   --  operation with the given client and redirect URL.
   function Is_Valid_State (App   : in Application;
                            Nonce : in String;
                            State : in String) return Boolean;

   --  OAuth 2.0 Section 4.1.3.  Access Token Request
   --            Section 4.1.4.  Access Token Response

   --  Exchange the OAuth code into an access token.
   function Request_Access_Token (App  : in Application;
                                  Code : in String) return Access_Token_Access;

   --  Create the access token
   function Create_Access_Token (App     : in Application;
                                 Token   : in String;
                                 Expires : in Natural) return Access_Token_Access;

private

   type Access_Token (Len : Natural) is new Security.Principal with record
      Access_Id : String (1 .. Len);
   end record;

   type Application is tagged record
      Client_Id   : Ada.Strings.Unbounded.Unbounded_String;
      Secret      : Ada.Strings.Unbounded.Unbounded_String;
      Callback    : Ada.Strings.Unbounded.Unbounded_String;
      Request_URI : Ada.Strings.Unbounded.Unbounded_String;
      Protect     : Ada.Strings.Unbounded.Unbounded_String;
      Key         : Ada.Strings.Unbounded.Unbounded_String;
   end record;

end Security.OAuth.Clients;

-----------------------------------------------------------------------
--  security-oauth -- OAuth Security
--  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 Ada.Strings.Unbounded;

--  The Security.OAuth.Clients package implements the client OAuth 2.0 authorization.
--
--  Note: OAuth 1.0 could be implemented but since it's being deprecated it's not worth doing it.
package Security.OAuth.Clients is

   --  ------------------------------
   --  Access Token
   --  ------------------------------
   --  Access tokens are credentials used to access protected resources.
   --  The access token is represented as a Principal.  This is an opaque
   --  value for an application.
   type Access_Token (Len : Natural) is new Security.Principal with private;
   type Access_Token_Access is access all Access_Token'Class;

   --  Get the principal name.  This is the OAuth access token.
   function Get_Name (From : in Access_Token) return String;

   type OpenID_Token (Len, Id_Len, Refresh_Len : Natural) is new Access_Token with private;
   type OpenID_Token_Access is access all OpenID_Token'Class;

   --  Get the id_token that was returned by the authentication process.
   function Get_Id_Token (From : in OpenID_Token) return String;

   --  ------------------------------
   --  Application
   --  ------------------------------
   --  The Application holds the necessary information to let a user
   --  grant access to its protected resources on the resource server.  It contains
   --  information that allows the OAuth authorization server to identify the
   --  application (client id and secret key).
   type Application is tagged private;

   --  Get the application identifier.
   function Get_Application_Identifier (App : in Application) return String;

   --  Set the application identifier used by the OAuth authorization server
   --  to identify the application (for example, the App ID in Facebook).
   procedure Set_Application_Identifier (App    : in out Application;
                                         Client : in String);

   --  Set the application secret defined in the OAuth authorization server
   --  for the application (for example, the App Secret in Facebook).
   procedure Set_Application_Secret (App    : in out Application;
                                     Secret : in String);

   --  Set the redirection callback that will be used to redirect the user
   --  back to the application after the OAuth authorization is finished.
   procedure Set_Application_Callback (App : in out Application;
                                       URI : in String);

   --  Set the OAuth authorization server URI that the application must use
   --  to exchange the OAuth code into an access token.
   procedure Set_Provider_URI (App : in out Application;
                               URI : in String);

   --  OAuth 2.0 Section 4.1.1  Authorization Request

   --  Build a unique opaque value used to prevent cross-site request forgery.
   --  The Nonce parameters is an optional but recommended unique value
   --  used only once.  The state value will be returned back by the OAuth provider.
   --  This protects the <tt>client_id</tt> and <tt>redirect_uri</tt> parameters.
   function Get_State (App   : in Application;
                       Nonce : in String) return String;

   --  Get the authenticate parameters to build the URI to redirect the user to
   --  the OAuth authorization form.
   function Get_Auth_Params (App : in Application;
                             State : in String;
                             Scope : in String := "") return String;

   --  OAuth 2.0 Section 4.1.2  Authorization Response

   --  Verify that the State opaque value was created by the Get_State
   --  operation with the given client and redirect URL.
   function Is_Valid_State (App   : in Application;
                            Nonce : in String;
                            State : in String) return Boolean;

   --  OAuth 2.0 Section 4.1.3.  Access Token Request
   --            Section 4.1.4.  Access Token Response

   --  Exchange the OAuth code into an access token.
   function Request_Access_Token (App  : in Application;
                                  Code : in String) return Access_Token_Access;

   --  Create the access token
   function Create_Access_Token (App      : in Application;
                                 Token    : in String;
                                 Refresh  : in String;
                                 Id_Token : in String;
                                 Expires  : in Natural) return Access_Token_Access;

private

   type Access_Token (Len : Natural) is new Security.Principal with record
      Access_Id : String (1 .. Len);
   end record;

   type OpenID_Token (Len, Id_Len, Refresh_Len : Natural) is new Access_Token (Len) with record
      Id_Token      : String (1 .. Id_Len);
      Refresh_Token : String (1 .. Refresh_Len);
   end record;

   type Application is tagged record
      Client_Id   : Ada.Strings.Unbounded.Unbounded_String;
      Secret      : Ada.Strings.Unbounded.Unbounded_String;
      Callback    : Ada.Strings.Unbounded.Unbounded_String;
      Request_URI : Ada.Strings.Unbounded.Unbounded_String;
      Protect     : Ada.Strings.Unbounded.Unbounded_String;
      Key         : Ada.Strings.Unbounded.Unbounded_String;
   end record;

end Security.OAuth.Clients;

Add support for OpenID Connect token

Add support for OpenID Connect token


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

package body EL.Variables is

   --  ------------------------------
   --  Get the Value_Expression that corresponds to the given variable name.
   --  ------------------------------
   function Get_Variable (Mapper : in Variable_Mapper'Class;
                          Name   : in Unbounded_String)
                          return EL.Expressions.Value_Expression is
   begin
      return EL.Expressions.Create_Expression (Mapper.Get_Variable (Name));
   end Get_Variable;

   --  ------------------------------
   --  Set the variable to the given value expression.
   --  ------------------------------
   procedure Set_Variable (Mapper : in out Variable_Mapper'Class;
                           Name   : in Unbounded_String;
                           Value  : in EL.Expressions.Value_Expression) is
   begin
      Mapper.Set_Variable (Name, EL.Expressions.Expression (Value));
   end Set_Variable;

end EL.Variables;

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

package body EL.Variables is

   --  ------------------------------
   --  Get the Value_Expression that corresponds to the given variable name.
   --  ------------------------------
   function Get_Variable (Mapper : in Variable_Mapper'Class;
                          Name   : in Unbounded_String)
                          return EL.Expressions.Value_Expression is
      VE : constant EL.Expressions.Expression := Mapper.Get_Variable (Name);
   begin
      return EL.Expressions.Create_Expression (VE);
   end Get_Variable;

   --  ------------------------------
   --  Set the variable to the given value expression.
   --  ------------------------------
   procedure Set_Variable (Mapper : in out Variable_Mapper'Class;
                           Name   : in Unbounded_String;
                           Value  : in EL.Expressions.Value_Expression) is
   begin
      Mapper.Set_Variable (Name, EL.Expressions.Expression (Value));
   end Set_Variable;

end EL.Variables;

Fix compilation with gcc 4.7

Fix compilation with gcc 4.7