-----------------------------------------------------------------------
--  awa-oauth-filters -- OAuth filter
--  Copyright (C) 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 Ada.Strings.Unbounded;

with ASF.Requests;
with ASF.Responses;
with ASF.Sessions;
with ASF.Principals;
with ASF.Filters;
with ASF.Servlets;
with ASF.Security.Filters;

with AWA.Users.Principals;
with AWA.OAuth.Services;
package AWA.OAuth.Filters is

   --  ------------------------------
   --  OAuth Authentication filter
   --  ------------------------------
   --  The <b>Auth_Filter</b> verifies that the access token passed for the OAuth
   --  operation is valid and it extracts the user to configure the request principal.
   type Auth_Filter is new ASF.Filters.Filter with private;

   --  Initialize the filter.
   overriding
   procedure Initialize (Filter  : in out Auth_Filter;
                         Config  : in ASF.Servlets.Filter_Config);

   --  The Do_Filter method of the Filter is called by the container each time
   --  a request/response pair is passed through the chain due to a client request
   --  for a resource at the end of the chain.  The Filter_Chain passed in to this
   --  method allows the Filter to pass on the request and response to the next
   --  entity in the chain.
   --
   --  Before passing the control to the next filter, initialize the service
   --  context to give access to the current application, current user and
   --  manage possible transaction rollbacks.
   overriding
   procedure Do_Filter (F        : in Auth_Filter;
                        Request  : in out ASF.Requests.Request'Class;
                        Response : in out ASF.Responses.Response'Class;
                        Chain    : in out ASF.Servlets.Filter_Chain);

private

   use Ada.Strings.Unbounded;

   type Auth_Filter is new ASF.Filters.Filter with record
      Realm : AWA.OAuth.Services.Auth_Manager_Access;
   end record;

end AWA.OAuth.Filters;

Define the OAuth security filter for AWA applications


-----------------------------------------------------------------------
--  util-commands-tests - Test for commands
--  Copyright (C) 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 Util.Commands.Tests is

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

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

   --  Tests when the execution of commands.
   procedure Test_Execute (T : in out Test);

   --  Test execution of help.
   procedure Test_Help (T : in out Test);

   --  Test usage operation.
   procedure Test_Usage (T : in out Test);

end Util.Commands.Tests;

Add tests for the Util.Commands.Drivers package


-----------------------------------------------------------------------
--  wiki-nodes -- Wiki Document Internal representation
--  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.
-----------------------------------------------------------------------

package body Wiki.Nodes is

   --  ------------------------------
   --  Create a text node.
   --  ------------------------------
   function Create_Text (Text : in WString) return Node_Type_Access is
   begin
      return new Node_Type '(Kind => N_TEXT,
                             Len  => Text'Length,
                             Text => Text,
                             others => <>);
   end Create_Text;

end Wiki.Nodes;

Implement the Create_Text function

Implement the Create_Text function


-----------------------------------------------------------------------
--  druss-commands-ping -- Ping devices from the gateway
--  Copyright (C) 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.
-----------------------------------------------------------------------

package Druss.Commands.Ping is

   type Command_Type is new Druss.Commands.Drivers.Command_Type with null record;

   procedure Do_Ping (Command   : in Command_Type;
                      Args      : in Argument_List'Class;
                      Context   : in out Context_Type);

   --  Execute a ping from the gateway to each device.
   overriding
   procedure Execute (Command   : in Command_Type;
                      Name      : in String;
                      Args      : in Argument_List'Class;
                      Context   : in out Context_Type);

   --  Write the help associated with the command.
   overriding
   procedure Help (Command   : in Command_Type;
                   Context   : in out Context_Type);

end Druss.Commands.Ping;

Define the ping command to ask the Bbox to ping the known devices


-----------------------------------------------------------------------
--  util-commands -- Support to make command line tools
--  Copyright (C) 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 Ada.Command_Line;
package body Util.Commands is

   --  ------------------------------
   --  Get the number of arguments available.
   --  ------------------------------
   overriding
   function Get_Count (List : in Default_Argument_List) return Natural is
   begin
      return Ada.Command_Line.Argument_Count - List.Offset;
   end Get_Count;

   --  ------------------------------
   --  Get the argument at the given position.
   --  ------------------------------
   overriding
   function Get_Argument (List : in Default_Argument_List;
                          Pos  : in Positive) return String is
   begin
      return Ada.Command_Line.Argument (Pos - List.Offset);
   end Get_Argument;

end Util.Commands;

Implement the Get_Count and Get_Argument operations


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

with Ada.Text_IO;
with Ada.Directories;
with Util.Test_Caller;

with MAT.Frames.Print;
with MAT.Readers.Files;
package body MAT.Frames.Tests is

   use Util.Tests;

   package Caller is new Util.Test_Caller (Test, "Files");

   --  Builtin and well known definition of test frames.
   Frame_1_0 : constant Frame_Table (1 .. 10) :=
     (1_0, 1_2, 1_3, 1_4, 1_5, 1_6, 1_7, 1_8, 1_9, 1_10);

   Frame_1_1 : constant Frame_Table (1 .. 15) :=
     (1_0, 1_2, 1_3, 1_4, 1_5, 1_6, 1_7, 1_8, 1_9, 1_10,
      1_11, 1_12, 1_13, 1_14, 1_15);

   Frame_1_2 : constant Frame_Table (1 .. 16) :=
     (1_0, 1_2, 1_3, 1_4, 1_5, 1_6, 1_7, 1_8, 1_9, 1_10,
      1_11, 1_12, 1_13, 1_14, 1_20, 1_21);

   Frame_1_3 : constant Frame_Table (1 .. 15) :=
     (1_0, 1_2, 1_3, 1_4, 1_5, 1_6, 1_7, 1_8, 1_9, 1_10,
      1_11, 1_12, 1_13, 1_14, 1_30);

   Frame_2_0 : constant Frame_Table (1 .. 10) :=
     (2_0, 2_2, 2_3, 2_4, 2_5, 2_6, 2_7, 2_8, 2_9, 2_10);

   Frame_2_1 : constant Frame_Table (1 .. 10) :=
     (2_0, 2_1, 2_1, 2_1, 2_1, 2_1, 2_1, 2_1, 2_1, 2_10);

   Frame_2_2 : constant Frame_Table (1 .. 10) :=
     (2_0, 2_1, 2_2, 2_1, 2_1, 2_1, 2_1, 2_1, 2_1, 2_1);

   Frame_2_3 : constant Frame_Table (1 .. 10) :=
     (2_0, 2_1, 2_2, 2_1, 2_1, 2_3, 2_1, 2_1, 2_1, 2_1);

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test MAT.Frames.Insert",
                       Test_Simple_Frames'Access);
      Caller.Add_Test (Suite, "Test MAT.Frames.Find",
                       Test_Find_Frames'Access);
      Caller.Add_Test (Suite, "Test MAT.Frames.Backtrace",
                       Test_Complex_Frames'Access);
   end Add_Tests;

   --  ------------------------------
   --  Create a tree with the well known test frames.
   --  ------------------------------
   function Create_Test_Frames return Frame_Type is
      Root : Frame_Type := Create_Root;
      F    : Frame_Type;
   begin
      Insert (Root, Frame_1_0, F);
      Insert (Root, Frame_1_1, F);
      Insert (Root, Frame_1_2, F);
      Insert (Root, Frame_1_3, F);
      Insert (Root, Frame_2_0, F);
      Insert (Root, Frame_2_1, F);
      Insert (Root, Frame_2_2, F);
      Insert (Root, Frame_2_3, F);
      return Root;
   end Create_Test_Frames;

   --  ------------------------------
   --  Basic consistency checks when creating the test tree
   --  ------------------------------
   procedure Test_Simple_Frames (T : in out Test) is
      Root : Frame_Type := Create_Root;
      F    : Frame_Type;
   begin
      --  Consistency check on empty tree.
      Util.Tests.Assert_Equals (T, 0, Count_Children (Root),
                                "Empty frame: Count_Children must return 0");
      Util.Tests.Assert_Equals (T, 0, Current_Depth (Root),
                                "Empty frame: Current_Depth must return 0");

      --  Insert first frame and verify consistency.
      Insert (Root, Frame_1_0, F);
      Util.Tests.Assert_Equals (T, 1, Count_Children (Root),
                                "Simple frame: Count_Children must return 1");
      Util.Tests.Assert_Equals (T, 10, Current_Depth (F),
                                "Simple frame: Current_Depth must return 10");
--        Expect (Msg    => "Frames.Count_Children",
--                Val    => 1,
--                Result => Count_Children (Root));
--        Expect (Msg    => "Frames.Count_Children(recursive)",
--                Val    => 1,
--                Result => Count_Children (Root, True));
--        Expect (Msg    => "Frames.Current_Depth",
--                Val    => 10,
--                Result => Current_Depth (F));

      Insert (Root, Frame_1_1, F);
      Insert (Root, Frame_1_2, F);
      Insert (Root, Frame_1_3, F);
      if Verbose then
         MAT.Frames.Print (Ada.Text_IO.Standard_Output, Root);
      end if;
      Util.Tests.Assert_Equals (T, 1, Count_Children (Root),
                                "Simple frame: Count_Children must return 1");
      Util.Tests.Assert_Equals (T, 3, Count_Children (Root, True),
                                "Simple frame: Count_Children (recursive) must return 3");
      Util.Tests.Assert_Equals (T, 15, Current_Depth (F),
                                "Simple frame: Current_Depth must return 15");

      Insert (Root, Frame_2_0, F);
      Insert (Root, Frame_2_1, F);
      Insert (Root, Frame_2_2, F);
      Insert (Root, Frame_2_3, F);
      if Verbose then
         MAT.Frames.Print (Ada.Text_IO.Standard_Output, Root);
      end if;
      Util.Tests.Assert_Equals (T, 2, Count_Children (Root),
                                "Simple frame: Count_Children must return 2");
      Util.Tests.Assert_Equals (T, 7, Count_Children (Root, True),
                                "Simple frame: Count_Children (recursive) must return 7");
      Util.Tests.Assert_Equals (T, 10, Current_Depth (F),
                                "Simple frame: Current_Depth must return 10");

      Destroy (Root);
   end Test_Simple_Frames;

   --  ------------------------------
   --  Test searching in the frame.
   --  ------------------------------
   procedure Test_Find_Frames (T : in out Test) is
      Root    : Frame_Type := Create_Test_Frames;
      Result  : Frame_Type;
      Last_Pc : Natural;
   begin
      --  Find exact frame.
      Find (Root, Frame_2_3, Result, Last_Pc);
      T.Assert (Result /= Root, "Frames.Find must return a valid frame");
      T.Assert (Last_Pc = 0, "Frames.Find must return a 0 Last_Pc");

      declare
         Pc : Frame_Table (1 .. 8) := Frame_2_3 (1 .. 8);
      begin
         Find (Root, Pc, Result, Last_Pc);

         T.Assert (Result /= Root, "Frames.Find must return a valid frame");
--           Expect (Msg    => "Frames.Find (Last_Pc param)",
--                   Val    => 0,
--                   Result => Last_Pc);
      end;

      Destroy (Root);
   end Test_Find_Frames;

   --  ------------------------------
   --  Create a complex frame tree and run tests on it.
   --  ------------------------------
   procedure Test_Complex_Frames (T : in out Test) is

      Pc   : Frame_Table (1 .. 8);
      Root : Frame_Type := Create_Root;

      procedure Create_Frame (Depth : in Natural);

      procedure Create_Frame (Depth : in Natural) is
         use type MAT.Types.Target_Addr;
         use type MAT.Events.Frame_Table;

         F : Frame_Type;
      begin
         Pc (Depth) := MAT.Types.Target_Addr (Depth);
         if Depth < Pc'Last then
            Create_Frame (Depth + 1);
         end if;

         Insert (Root, Pc (1 .. Depth), F);
         Pc (Depth) := MAT.Types.Target_Addr (Depth) + 1000;
         Insert (Root, Pc (1 .. Depth), F);
         if Depth < Pc'Last then
            Create_Frame (Depth + 1);
         end if;

         declare
            Read_Pc : Frame_Table := Backtrace (F);
         begin
            T.Assert (Read_Pc = Pc (1 .. Depth), "Frames.backtrace (same as inserted)");
            if Verbose then
               for I in Read_Pc'Range loop
                  Ada.Text_IO.Put (" " & MAT.Types.Target_Addr'Image (Read_Pc (I)));
               end loop;
               Ada.Text_IO.New_Line;
            end if;
         end;
      end Create_Frame;

   begin
      Create_Frame (1);
      if Verbose then
         MAT.Frames.Print (Ada.Text_IO.Standard_Output, Root);
      end if;
      Destroy (Root);
   end Test_Complex_Frames;

end MAT.Frames.Tests;

Implement some unit tests for the stack frame tree


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

package body MAT.Targets.Readers is

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

   MSG_BEGIN  : constant MAT.Events.Internal_Reference := 0;
   MSG_END    : constant MAT.Events.Internal_Reference := 1;

   M_PID      : constant MAT.Events.Internal_Reference := 1;
   M_EXE      : constant MAT.Events.Internal_Reference := 2;

   PID_NAME   : aliased constant String := "pid";
   EXE_NAME   : aliased constant String := "exe";

   Process_Attributes : aliased constant MAT.Events.Attribute_Table :=
     (1 => (Name => PID_NAME'Access, Size => 0,
            Kind => MAT.Events.T_SIZE_T, Ref => M_PID),
      2 => (Name => EXE_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_EXE));

   procedure Create_Process (For_Servant : in out Process_Servant;
                             Pid         : in MAT.Types.Target_Process_Ref) is
   begin
      MAT.Memory.Targets.Initialize (Memory => For_Servant.Process.Memory,
                                     Reader => For_Servant.Reader.all);
   end Create_Process;

   overriding
   procedure Dispatch (For_Servant : in out Process_Servant;
                       Id          : in MAT.Events.Internal_Reference;
                       Params      : in MAT.Events.Const_Attribute_Table_Access;
                       Frame       : in MAT.Events.Frame_Info;
                       Msg         : in out MAT.Readers.Message) is
   begin
      case Id is
         when MSG_BEGIN =>
            null;

         when MSG_END =>
            null;

         when others =>
            null;

      end case;
   end Dispatch;

   --  Register the reader to extract and analyze process events.
   procedure Register (Into   : in out MAT.Readers.Manager_Base'Class;
                       Reader : in Process_Reader_Access) is
   begin
      Into.Register_Reader (Reader.all'Access, "begin", MSG_BEGIN,
                            Process_Attributes'Access);
      Into.Register_Reader (Reader.all'Access, "end", MSG_END,
                            Process_Attributes'Access);
   end Register;

end MAT.Targets.Readers;

Implement the package to read the begin/end events and create the process instance


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

with Util.Test_Caller;
with Util.Beans.Objects;

with ASF.Tests;
with ASF.Requests.Mockup;
with ASF.Responses.Mockup;
with ASF.Applications.Main;
with ASF.Applications.Main.Configs;
with ASF.Applications.Tests;
package body ASF.Navigations.Tests is

   use Util.Beans.Objects;
   use ASF.Tests;

   package Caller is new Util.Test_Caller (Test, "Navigations");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test navigation exact match (view, outcome, action)",
                       Test_Exact_Navigation'Access);

      Caller.Add_Test (Suite, "Test navigation partial match (view, outcome)",
                       Test_Partial_Navigation'Access);

      Caller.Add_Test (Suite, "Test navigation exception match (view, outcome)",
                       Test_Exception_Navigation'Access);

   end Add_Tests;

   --  ------------------------------
   --  Initialize the test application
   --  ------------------------------
   overriding
   procedure Set_Up (T : in out Test) is
      pragma Unreferenced (T);

      use type ASF.Applications.Main.Application_Access;
      Fact     : ASF.Applications.Main.Application_Factory;
   begin
      if ASF.Tests.Get_Application = null then
         ASF.Tests.Initialize (Util.Tests.Get_Properties, Factory => Fact);
      end if;
   end Set_Up;

   --  ------------------------------
   --  Check the navigation for an URI and expect the result to match the regular expression.
   --  ------------------------------
   procedure Check_Navigation (T     : in out Test;
                               Name  : in String;
                               Match : in String;
                               Raise_Flag : in Boolean := False) is
      Request  : ASF.Requests.Mockup.Request;
      Reply    : ASF.Responses.Mockup.Response;
      Form     : aliased ASF.Applications.Tests.Form_Bean;
      File     : constant String := Util.Tests.Get_Path ("regtests/config/test-navigations.xml");
   begin
      Form.Perm_Error := Raise_Flag;
      ASF.Applications.Main.Configs.Read_Configuration (ASF.Tests.Get_Application.all, File);
      Request.Set_Attribute ("form", To_Object (Value   => Form'Unchecked_Access,
                                                Storage => STATIC));
      Do_Get (Request, Reply, "/tests/" & Name & ".html", Name & ".txt");

      Request.Set_Parameter ("formText", "1");
      Request.Set_Parameter ("name", "John");
      Request.Set_Parameter ("password", "12345");
      Request.Set_Parameter ("email", "john@gmail.com");
      Request.Set_Parameter ("ok", "1");
      Do_Post (Request, Reply, "/tests/" & Name & ".html", Name & "form-navigation-exact.txt");
      Assert_Matches (T, Match,
                      Reply, "Wrong generated content");
   end Check_Navigation;

   --  ------------------------------
   --  Test a form navigation with an exact match (view, outcome, action).
   --  ------------------------------
   procedure Test_Exact_Navigation (T : in out Test) is
   begin
      T.Check_Navigation ("form-nav", ".*success.*");
   end Test_Exact_Navigation;

   --  ------------------------------
   --  Test a form navigation with a partial match (view, outcome).
   --  ------------------------------
   procedure Test_Partial_Navigation (T : in out Test) is
   begin
      T.Check_Navigation ("form-nav-partial", ".*success partial.*");
   end Test_Partial_Navigation;

   --  ------------------------------
   --  Test a form navigation with a exception match (view, outcome).
   --  ------------------------------
   procedure Test_Exception_Navigation (T : in out Test) is
   begin
      T.Check_Navigation ("form-nav-exception", ".*success exception.*", True);
   end Test_Exception_Navigation;

end ASF.Navigations.Tests;

Add navigation rule unit test

Add navigation rule unit test


-----------------------------------------------------------------------
--  convert -- Convert a wiki format into another
--  Copyright (C) 2022 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.Wide_Wide_Text_IO;
with Ada.IO_Exceptions;
with Ada.Strings.Unbounded;
with Ada.Strings.UTF_Encoding.Wide_Wide_Strings;

with GNAT.Command_Line;

with Util.Files;
with Util.Strings.Transforms;

with Wiki.Strings;
with Wiki.Filters.Html;
with Wiki.Filters.TOC;
with Wiki.Streams.Builders;
with Wiki.Render.Wiki;
with Wiki.Documents;
with Wiki.Parsers;

procedure Convert is

   use GNAT.Command_Line;
   use Ada.Strings.Unbounded;
   use Ada.Strings.UTF_Encoding;

   procedure Usage;
   procedure Parse (Content : in String);
   procedure Print (Item : in Wiki.Strings.WString);
   function To_Syntax (Name : in String) return Wiki.Wiki_Syntax;

   Html_Filter : aliased Wiki.Filters.Html.Html_Filter_Type;
   TOC         : aliased Wiki.Filters.TOC.TOC_Filter;
   Count       : Natural := 0;
   Src_Syntax  : Wiki.Wiki_Syntax := Wiki.SYNTAX_MARKDOWN;
   Dst_Syntax  : Wiki.Wiki_Syntax := Wiki.SYNTAX_MARKDOWN;

   procedure Usage is
   begin
      Ada.Text_IO.Put_Line ("Convert a wiki file from one format to another");
      Ada.Text_IO.Put_Line ("Usage: convert [-s format] [-d format] file...");
      Ada.Text_IO.Put_Line ("  -s format  Define the source file format");
      Ada.Text_IO.Put_Line ("  -d format  Define the destination file format");
   end Usage;

   procedure Print (Item : in Wiki.Strings.WString) is
   begin
      Ada.Wide_Wide_Text_IO.Put (Item);
   end Print;

   procedure Parse (Content : in String) is
      Doc      : Wiki.Documents.Document;
      Engine   : Wiki.Parsers.Parser;
      Stream   : aliased Wiki.Streams.Builders.Output_Builder_Stream;
      Renderer : aliased Wiki.Render.Wiki.Wiki_Renderer;
   begin
      Engine.Add_Filter (TOC'Unchecked_Access);
      Engine.Add_Filter (Html_Filter'Unchecked_Access);
      Engine.Set_Syntax (Src_Syntax);
      Engine.Parse (Wide_Wide_Strings.Decode (Content), Doc);

      Renderer.Set_Output_Stream (Stream'Unchecked_Access, Dst_Syntax);
      Renderer.Render (Doc);
      Stream.Iterate (Print'Access);
      Ada.Wide_Wide_Text_IO.New_Line;
   end Parse;

   function To_Syntax (Name : in String) return Wiki.Wiki_Syntax is
   begin
      if Name = "markdown" then
         return Wiki.SYNTAX_MARKDOWN;
      end if;

      if Name = "dotclear" then
         return Wiki.SYNTAX_DOTCLEAR;
      end if;

      if Name = "creole" then
         return Wiki.SYNTAX_CREOLE;
      end if;

      if Name = "textile" then
         return Wiki.SYNTAX_TEXTILE;
      end if;

      if Name = "mediawiki" then
         return Wiki.SYNTAX_MEDIA_WIKI;
      end if;

      if Name = "html" then
         return Wiki.SYNTAX_HTML;
      end if;

      return Wiki.SYNTAX_MARKDOWN;
   end To_Syntax;

begin
   loop
      case Getopt ("s: d:") is

         when 's' =>
            declare
               Value : constant String := Util.Strings.Transforms.To_Lower_Case (Parameter);
            begin
               Src_Syntax := To_Syntax (Value);

            exception
               when Constraint_Error =>
                  Ada.Text_IO.Put_Line ("Invalid source format " & Value);
            end;

         when 'd' =>
            declare
               Value : constant String := Util.Strings.Transforms.To_Lower_Case (Parameter);
            begin
               Dst_Syntax := To_Syntax (Value);

            exception
               when Constraint_Error =>
                  Ada.Text_IO.Put_Line ("Invalid source format " & Value);
            end;

         when others =>
            exit;
      end case;
   end loop;

   loop
      declare
         Name : constant String := GNAT.Command_Line.Get_Argument;
         Data : Unbounded_String;
      begin
         if Name = "" then
            if Count = 0 then
               Usage;
            end if;
            return;
         end if;
         Count := Count + 1;
         Util.Files.Read_File (Name, Data);
         Parse (To_String (Data));

      exception
         when Ada.IO_Exceptions.Name_Error =>
            Ada.Text_IO.Put_Line ("Cannot read file '" & Name & "'");

      end;
   end loop;

exception
   when Invalid_Switch =>
      Ada.Text_IO.Put_Line ("Invalid option.");
      Usage;

end Convert;

Add new example to convert a wiki syntax into another


with Ada.Text_IO;
with Ada.Command_Line;
with Util.Beans.Objects;
procedure ObjCalc is

   package UBO renames Util.Beans.Objects;

   use type UBO.Object;

   Value : UBO.Object := UBO.To_Object (Integer (0));
begin
   Value := Value + UBO.To_Object (Integer (123));
   Value := Value - UBO.To_Object (String '("12"));

   --  Should print '111'
   Ada.Text_IO.Put_Line (UBO.To_String (Value));
end ObjCalc;

Add very simple examples for Objects

Add very simple examples for Objects


------------------------------------------------------------------------------
--                                                                          --
--                 ASIS-for-GNAT IMPLEMENTATION COMPONENTS                  --
--                                                                          --
--                A S I S . A D A _ E N V I R O N M E N T S                 --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--            Copyright (C) 1995-2008, Free Software Foundation, Inc.       --
--                                                                          --
-- ASIS-for-GNAT is free software; you can redistribute it and/or modify it --
-- under terms of the  GNU General Public License  as published by the Free --
-- Software Foundation;  either version 2,  or  (at your option)  any later --
-- version. ASIS-for-GNAT is distributed  in the hope  that it will be use- --
-- ful, but WITHOUT ANY WARRANTY; without even the implied warranty of MER- --
-- CHANTABILITY  or  FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General --
-- Public License for more details.  You should have received a copy of the --
-- GNU  General  Public License  distributed with ASIS-for-GNAT; see   file --
-- COPYING.  If not,  write  to the  Free Software Foundation,  51 Franklin --
-- Street, Fifth Floor, Boston, MA 02110-1301, USA.                         --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
-- ASIS-for-GNAT was originally developed  by the ASIS-for-GNAT team at the --
-- Software  Engineering  Laboratory  of  the Swiss  Federal  Institute  of --
-- Technology (LGL-EPFL) in Lausanne,  Switzerland, in cooperation with the --
-- Scientific  Research  Computer  Center of  Moscow State University (SRCC --
-- MSU), Russia,  with funding partially provided  by grants from the Swiss --
-- National  Science  Foundation  and  the  Swiss  Academy  of  Engineering --
-- Sciences. ASIS-for-GNAT is now maintained by AdaCore                     --
-- (http://www.adaccore.com).                                               --
--                                                                          --
------------------------------------------------------------------------------

with Ada.Characters.Handling; use Ada.Characters.Handling;
with Ada.Strings;             use Ada.Strings;
with Ada.Strings.Fixed;       use Ada.Strings.Fixed;

with Asis.Errors;             use Asis.Errors;
with Asis.Exceptions;         use Asis.Exceptions;

with Asis.Set_Get;            use Asis.Set_Get;

with A4G.A_Debug;             use A4G.A_Debug;
with A4G.A_Opt;               use A4G.A_Opt;
with A4G.A_Output;            use A4G.A_Output;
with A4G.Contt;               use A4G.Contt;
with A4G.Contt.TT;            use A4G.Contt.TT;
with A4G.Contt.UT;            use A4G.Contt.UT;
with A4G.Vcheck;              use A4G.Vcheck;

with Output;                  use Output;

package body Asis.Ada_Environments is

   Package_Name : constant String := "Asis.Ada_Environments.";

   ---------------
   -- Associate --
   ---------------

   procedure Associate
     (The_Context : in out Asis.Context;
      Name        :        Wide_String;
      Parameters  :        Wide_String := Default_Parameters)
   is
      S_Parameters : constant String := Trim (To_String (Parameters), Both);
      Cont         :          Context_Id;
   begin

      Cont := Get_Cont_Id (The_Context);

      if not A4G.A_Opt.Is_Initialized then

         Set_Error_Status
           (Status    => Initialization_Error,
            Diagnosis => Package_Name & "Associate: "
                       & "called for non-initialized ASIS");

         raise ASIS_Failed;

      end if;

      if Is_Opened (Cont) then
         Set_Error_Status
           (Status    => Value_Error,
            Diagnosis => Package_Name & "Associate: "
                       & "the Context has already been opened");
         raise ASIS_Inappropriate_Context;
      end if;

      if Cont = Non_Associated then
         --  this is the first association for a given Context
         Cont := Allocate_New_Context;
         Set_Cont (The_Context, Cont);
      else
         Erase_Old (Cont);
      end if;

      Verify_Context_Name (To_String (Name), Cont);
      Process_Context_Parameters (S_Parameters, Cont);

      Set_Is_Associated (Cont, True);

      Save_Context (Cont);
      Set_Current_Cont (Nil_Context_Id);

   exception
      when ASIS_Inappropriate_Context =>
         Set_Is_Associated (Cont, False);
         raise;
      when ASIS_Failed =>
         Set_Is_Associated (Cont, False);

         if Status_Indicator = Unhandled_Exception_Error then
            Add_Call_Information (Outer_Call => Package_Name & "Associate");
         end if;

         raise;
      when Ex : others =>
         Set_Is_Associated (Cont, False);

         Report_ASIS_Bug
           (Query_Name => Package_Name & "Associate",
            Ex         => Ex);
   end Associate;

   -----------
   -- Close --
   -----------

   procedure Close (The_Context : in out Asis.Context) is
      Cont : Context_Id;
   begin
      Cont := Get_Cont_Id (The_Context);
      Reset_Context (Cont);

      if not Is_Opened (Cont) then
         Set_Error_Status (Status    => Value_Error,
                           Diagnosis => Package_Name & "Close: " &
                           "the Context is not open");
         raise ASIS_Inappropriate_Context;
      end if;

      if Debug_Flag_C    or else
         Debug_Lib_Model or else
         Debug_Mode
      then
         Write_Str ("Closing Context ");
         Write_Int (Int (Cont));
         Write_Eol;
         Print_Units (Cont);
         Print_Trees (Cont);
      end if;

      Set_Is_Opened (Cont, False);

      Set_Current_Cont (Nil_Context_Id);

      Reset_Cache;

   exception
      when ASIS_Inappropriate_Context =>
         raise;
      when ASIS_Failed =>
         Set_Current_Cont (Nil_Context_Id);

         if Status_Indicator = Unhandled_Exception_Error then
            Add_Call_Information (Outer_Call => Package_Name &  "Close");
         end if;

         raise;
      when Ex : others =>
         Set_Current_Cont (Nil_Context_Id);
         Report_ASIS_Bug
           (Query_Name => Package_Name & "Associate",
            Ex         => Ex);
   end Close;

   -----------------
   -- Debug_Image --
   -----------------

   function Debug_Image
     (The_Context : Asis.Context)
      return        Wide_String
   is
      Arg_Cont : Context_Id;
      LT       : Wide_String renames A4G.A_Types.Asis_Wide_Line_Terminator;
   begin
      Arg_Cont := Get_Cont_Id (The_Context);
      Reset_Context (Arg_Cont);

      return LT & "Context Debug_Image: " &
             LT & "Context Id is" &
             Context_Id'Wide_Image (Arg_Cont) &
             LT & To_Wide_String (Debug_String (The_Context));
   exception
      when Ex : others =>
         Report_ASIS_Bug
          (Query_Name => Package_Name & "Debug_Image",
           Ex         => Ex);
   end Debug_Image;

   ------------------
   -- Default_Name --
   ------------------

   function Default_Name return Wide_String is
   begin
      return Nil_Asis_Wide_String;
   end Default_Name;

   ------------------------
   -- Default_Parameters --
   ------------------------

   function Default_Parameters return Wide_String is
   begin
      return Nil_Asis_Wide_String;
   end Default_Parameters;

   ----------------
   -- Dissociate --
   ----------------

   procedure Dissociate (The_Context : in out Asis.Context) is
      Cont : Context_Id;
   begin
      Cont := Get_Cont_Id (The_Context);

      if Is_Opened (Cont) then
         Set_Error_Status (Status    => Value_Error,
                           Diagnosis => Package_Name & "Dissociate: "
                                      & "the Context is open");
         raise ASIS_Inappropriate_Context;
      end if;

      if Debug_Flag_C    or else
         Debug_Lib_Model or else
         Debug_Mode
      then
         Write_Str ("Dissociating Context ");
         Write_Int (Int (Cont));
         Write_Eol;
         Print_Context_Parameters (Cont);
      end if;

      if Is_Associated (Cont) then
         Erase_Old (Cont);
         Set_Is_Associated (Cont, False);
      end if;

   exception
      when ASIS_Inappropriate_Context =>
         raise;
      when ASIS_Failed =>

         if Status_Indicator = Unhandled_Exception_Error then
            Add_Call_Information (Outer_Call => Package_Name & "Dissociate");
         end if;

         raise;
      when Ex : others =>
         Report_ASIS_Bug
           (Query_Name => Package_Name & "Dissociate",
            Ex         => Ex);
   end Dissociate;

   ------------
   -- Exists --
   ------------

   function Exists (The_Context : Asis.Context) return Boolean is
      Cont : Context_Id;
   begin
      Cont := Get_Cont_Id (The_Context);
      return Is_Associated (Cont);
   end Exists;

   ----------------------
   -- Has_Associations --
   ----------------------

   function Has_Associations
     (The_Context : Asis.Context)
      return        Boolean
   is
      Cont : Context_Id;
   begin
      Cont := Get_Cont_Id (The_Context);
      return Is_Associated (Cont);
   end Has_Associations;

   --------------
   -- Is_Equal --
   --------------

   function Is_Equal
     (Left  : Asis.Context;
      Right : Asis.Context)
      return  Boolean
   is
   begin
      return Get_Cont_Id (Left) = Get_Cont_Id (Right);
      --  Should be revised
   end Is_Equal;

   ------------------
   -- Is_Identical --
   ------------------

   function Is_Identical
     (Left  : Asis.Context;
      Right : Asis.Context)
      return  Boolean
   is
   begin
      return Get_Cont_Id (Left) = Get_Cont_Id (Right);
   end Is_Identical;

   -------------
   -- Is_Open --
   -------------

   function Is_Open (The_Context : Asis.Context) return Boolean is
      Cont : Context_Id;
   begin
      Cont := Get_Cont_Id (The_Context);
      return Is_Opened (Cont);
   end Is_Open;

   ----------
   -- Name --
   ----------

   function Name (The_Context : Asis.Context) return Wide_String is
      Cont : Context_Id;
   begin
      Cont := Get_Cont_Id (The_Context);
      return  To_Wide_String (Get_Context_Name (Cont));
   end Name;

   ----------
   -- Open --
   ----------

   procedure Open (The_Context : in out Asis.Context) is
      Cont              : Context_Id;
      Context_Tree_Mode : Tree_Mode;
   begin
      Cont := Get_Cont_Id (The_Context);

      if not Is_Associated (Cont) then
         Set_Error_Status (Status    => Value_Error,
                           Diagnosis => Package_Name & "Open: " &
                           "the Context does not have association");
         raise ASIS_Inappropriate_Context;
      elsif Is_Opened (Cont) then
         Set_Error_Status (Status    => Value_Error,
                           Diagnosis => Package_Name & "Open: " &
                           "the Context has already been opened");
         raise ASIS_Inappropriate_Context;
      end if;

      Reset_Context (Cont);
      Context_Tree_Mode := Tree_Processing_Mode (Cont);

      if Tree_Processing_Mode (Cont) = GNSA then
         Set_Error_Status (Status    => Use_Error,
                           Diagnosis => Package_Name & "Open: " &
                           "GNSA Context mode is not allowed");
         raise ASIS_Inappropriate_Context;
      end if;

      Increase_ASIS_OS_Time;

      Pre_Initialize (Cont);
      A4G.Contt.Initialize (Cont);
      --  Having these two Pre_Initialize and A4G.Contt.Initialize calling
      --  one after another is a kind of junk, but there are some problems
      --  with multi-context processing which have not been completely
      --  detected and which does not allow to get rid of this definitely
      --  redundunt "initialization"

      case Context_Tree_Mode is
         when Pre_Created | Mixed =>
            Scan_Trees_New (Cont);

         when Incremental =>

            --  Not the best approach, unfortunately
            begin
               Scan_Trees_New (Cont);
            exception
               when Inconsistent_Incremental_Context =>
                  --  Setting empty incremental context:
                  Pre_Initialize (Cont);
                  A4G.Contt.Initialize (Cont);
            end;

         when others =>
            null;
      end case;

      Set_Is_Opened (Cont, True);

      Save_Context (Cont);

      Set_Current_Cont (Nil_Context_Id);

   exception
      when Program_Error =>
         raise;
      when ASIS_Inappropriate_Context =>
         raise;
      when ASIS_Failed =>
         Set_Is_Opened (Cont, False);
         Set_Current_Cont (Nil_Context_Id);

         if Status_Indicator = Unhandled_Exception_Error then
            Add_Call_Information (Outer_Call => Package_Name & "Open");
         end if;

         raise;
      when Ex : others =>
         Set_Is_Opened (Cont, False);
         Set_Current_Cont (Nil_Context_Id);

         Report_ASIS_Bug
           (Query_Name => Package_Name & "Open",
            Ex         => Ex);
   end Open;

   ----------------
   -- Parameters --
   ----------------

   function Parameters (The_Context : Asis.Context) return Wide_String is
      Cont : Context_Id;
   begin
      Cont := Get_Cont_Id (The_Context);
      return  To_Wide_String (Get_Context_Parameters (Cont));
   end Parameters;

end Asis.Ada_Environments;

Add the ASIS file $i

Add the ASIS file $i


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

with System;
with Interfaces.C;
with Interfaces.C.Strings;
with Util.Systems.Constants;

package body Util.Systems.DLLs is

   function Sys_Dlopen (Path  : in Interfaces.C.Strings.chars_ptr;
                        Mode  : in Flags) return Handle;
   pragma Import (C, Sys_Dlopen, "dlopen");

   function Sys_Dlclose (Lib : in Handle) return Interfaces.C.int;
   pragma Import (C, Sys_Dlclose, "dlclose");

   function Sys_Dlsym (Lib    : in Handle;
                       Symbol : in Interfaces.C.Strings.chars_ptr) return System.Address;
   pragma Import (C, Sys_Dlsym, "dlsym");

   function Sys_Dlerror return Interfaces.C.Strings.chars_ptr;
   pragma Import (C, Sys_Dlerror, "dlerror");

   function Error_Message return String is
   begin
      return Interfaces.C.Strings.Value (Sys_Dlerror);
   end Error_Message;

   pragma Linker_Options ("-ldl");

   --  -----------------------
   --  Load the shared library with the given name or path and return a library handle.
   --  Raises the <tt>Load_Error</tt> exception if the library cannot be loaded.
   --  -----------------------
   function Load (Path : in String;
                  Mode : in Flags := Util.Systems.Constants.RTLD_LAZY) return Handle is
      Lib    : Interfaces.C.Strings.chars_ptr := Interfaces.C.Strings.New_String (Path);
      Result : Handle := Sys_Dlopen (Lib, Mode);
   begin
      Interfaces.C.Strings.Free (Lib);
      if Result = Null_Handle then
         raise Load_Error with Error_Message;
      else
         return Result;
      end if;
   end Load;

   --  -----------------------
   --  Unload the shared library.
   --  -----------------------
   procedure Unload (Lib : in Handle) is
      Result : Interfaces.C.int;
   begin
      if Lib /= Null_Handle then
         Result := Sys_Dlclose (Lib);
      end if;
   end Unload;

   --  -----------------------
   --  Get a global symbol with the given name in the library.
   --  Raises the <tt>Not_Found</tt> exception if the symbol does not exist.
   --  -----------------------
   function Get_Symbol (Lib  : in Handle;
                        Name : in String) return System.Address is
      use type System.Address;

      Symbol : Interfaces.C.Strings.Chars_Ptr := Interfaces.C.Strings.New_String (Name);
      Result : System.Address := Sys_Dlsym (Lib, Symbol);
   begin
      Interfaces.C.Strings.Free (Symbol);
      if Result = System.Null_Address then
         raise Not_Found with Error_Message;
      else
         return Result;
      end if;
   end Get_Symbol;

end Util.Systems.DLLs;

Implement the shared library support for Unix


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

package body Util.Texts.Builders is

   --  ------------------------------
   --  Get the length of the item builder.
   --  ------------------------------
   function Length (Source : in Builder) return Natural is
   begin
      return Source.Length;
   end Length;

   --  ------------------------------
   --  Get the capacity of the builder.
   --  ------------------------------
   function Capacity (Source : in Builder) return Natural is
      B : constant Block_Access := Source.Current;
   begin
      return Source.Length + B.Len - B.Last;
   end Capacity;

   --  ------------------------------
   --  Get the builder block size.
   --  ------------------------------
   function Block_Size (Source : in Builder) return Positive is
   begin
      return Source.Block_Size;
   end Block_Size;

   --  ------------------------------
   --  Set the block size for the allocation of next chunks.
   --  ------------------------------
   procedure Set_Block_Size (Source : in out Builder;
                             Size   : in Positive) is
   begin
      Source.Block_Size := Size;
   end Set_Block_Size;

   --  ------------------------------
   --  Append the <tt>New_Item</tt> at the end of the source growing the buffer if necessary.
   --  ------------------------------
   procedure Append (Source   : in out Builder;
                     New_Item : in Input) is
      B     : Block_Access := Source.Current;
      Start : Natural := New_Item'First;
      Last  : constant Natural := New_Item'Last;
   begin
      while Start <= Last loop
         declare
            Space : Natural := B.Len - B.Last;
            Size  : constant Natural := Last - Start + 1;
         begin
            if Space > Size then
               Space := Size;
            elsif Space = 0 then
               if Size > Source.Block_Size then
                  B.Next_Block := new Block (Size);
               else
                  B.Next_Block := new Block (Source.Block_Size);
               end if;
               B := B.Next_Block;
               Source.Current := B;
               if B.Len > Size then
                  Space := Size;
               else
                  Space  := B.Len;
               end if;
            end if;
            B.Content (B.Last + 1 .. B.Last + Space) := New_Item (Start .. Start + Space - 1);
            Source.Length := Source.Length + Space;
            B.Last := B.Last + Space;
            Start  := Start + Space;
         end;
      end loop;
   end Append;

   --  ------------------------------
   --  Append the <tt>New_Item</tt> at the end of the source growing the buffer if necessary.
   --  ------------------------------
   procedure Append (Source   : in out Builder;
                     New_Item : in Element_Type) is
      B     : Block_Access := Source.Current;
   begin
      if B.Len = B.Last then
         B.Next_Block := new Block (Source.Block_Size);
         B := B.Next_Block;
         Source.Current := B;
      end if;
      Source.Length := Source.Length + 1;
      B.Last := B.Last + 1;
      B.Content (B.Last) := New_Item;
   end Append;

   --  ------------------------------
   --  Clear the source freeing any storage allocated for the buffer.
   --  ------------------------------
   procedure Clear (Source : in out Builder) is
      procedure Free is
        new Ada.Unchecked_Deallocation (Object => Block, Name => Block_Access);
      Current, Next : Block_Access;
   begin
      Next := Source.First.Next_Block;
      while Next /= null loop
         Current := Next;
         Next    := Current.Next_Block;
         Free (Current);
      end loop;
      Source.First.Next_Block := null;
      Source.First.Last       := 0;
      Source.Current          := Source.First'Unchecked_Access;
      Source.Length           := 0;
   end Clear;

   --  ------------------------------
   --  Iterate over the buffer content calling the <tt>Process</tt> procedure with each
   --  chunk.
   --  ------------------------------
   procedure Iterate (Source  : in Builder;
                      Process : not null access procedure (Chunk : in Input)) is
   begin
      if Source.First.Last > 0 then
         Process (Source.First.Content (1 .. Source.First.Last));
         declare
            B : Block_Access := Source.First.Next_Block;
         begin
            while B /= null loop
               Process (B.Content (1 .. B.Last));
               B := B.Next_Block;
            end loop;
         end;
      end if;
   end Iterate;

   --  ------------------------------
   --  Get the buffer content as an array.
   --  ------------------------------
   function To_Array (Source : in Builder) return Input is
      Result : Input (1 .. Source.Length);
   begin
      if Source.First.Last > 0 then
         declare
            Pos : Positive := Source.First.Last;
            B   : Block_Access := Source.First.Next_Block;
         begin
            Result (1 .. Pos) := Source.First.Content (1 .. Pos);
            while B /= null loop
               Result (Pos + 1 .. Pos + B.Last) := B.Content (1 .. B.Last);
               Pos := Pos + B.Last;
               B   := B.Next_Block;
            end loop;
         end;
      end if;
      return Result;
   end To_Array;

   --  ------------------------------
   --  Setup the builder.
   --  ------------------------------
   overriding
   procedure Initialize (Source : in out Builder) is
   begin
      Source.Current := Source.First'Unchecked_Access;
   end Initialize;

   --  ------------------------------
   --  Finalize the builder releasing the storage.
   --  ------------------------------
   overriding
   procedure Finalize (Source : in out Builder) is
   begin
      Clear (Source);
   end Finalize;

end Util.Texts.Builders;

Implement the new package

Implement the new package


------------------------------------------------------------------------------
--                                                                          --
--                 ASIS-for-GNAT IMPLEMENTATION COMPONENTS                  --
--                                                                          --
--                          A 4 G . G N A T _ I N T                         --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--            Copyright (C) 1995-2012, Free Software Foundation, Inc.       --
--                                                                          --
-- ASIS-for-GNAT is free software; you can redistribute it and/or modify it --
-- under terms of the  GNU General Public License  as published by the Free --
-- Software Foundation;  either version 2,  or  (at your option)  any later --
-- version. ASIS-for-GNAT is distributed  in the hope  that it will be use- --
-- ful, but WITHOUT ANY WARRANTY; without even the implied warranty of MER- --
-- CHANTABILITY or  FITNESS FOR A PARTICULAR  PURPOSE.  See the GNU General --
-- Public License for more details.  You should have received a copy of the --
-- GNU  General  Public  License  distributed with ASIS-for-GNAT;  see file --
-- COPYING.  If not,  write  to the  Free Software Foundation,  51 Franklin --
-- Street, Fifth Floor, Boston, MA 02110-1301, USA.                         --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
-- ASIS-for-GNAT was originally developed  by the ASIS-for-GNAT team at the --
-- Software  Engineering  Laboratory  of  the Swiss  Federal  Institute  of --
-- Technology (LGL-EPFL) in Lausanne,  Switzerland, in cooperation with the --
-- Scientific  Research  Computer  Center of  Moscow State University (SRCC --
-- MSU), Russia,  with funding partially provided  by grants from the Swiss --
-- National  Science  Foundation  and  the  Swiss  Academy  of  Engineering --
-- Sciences. ASIS-for-GNAT is now maintained by AdaCore                     --
-- (http://www.adacore.com).                                                --
--                                                                          --
------------------------------------------------------------------------------

with Ada.Exceptions;
with Ada.Strings.Fixed;         use Ada.Strings.Fixed;
with Ada.Text_IO;               use Ada.Text_IO;

with GNAT.Directory_Operations; use GNAT.Directory_Operations;
with Asis.Errors;
with Asis.Exceptions;           use Asis.Exceptions;
with Asis.Extensions;           use Asis.Extensions;

with A4G.A_Debug;               use A4G.A_Debug;
with A4G.A_Opt;                 use A4G.A_Opt;
with A4G.A_Output;              use A4G.A_Output;
with A4G.Contt;                 use A4G.Contt;
with A4G.Vcheck;                use A4G.Vcheck;

with Aspects;
with Atree;
with Csets;
with Elists;
with Fname;
with Gnatvsn;
with Lib;
with Namet;
with Nlists;
with Opt;                       use Opt;
with Repinfo;
with Sem_Aux;
with Sinput;
with Stand;
with Stringt;
with Uintp;
with Urealp;
with Tree_IO;

package body A4G.GNAT_Int is

   LT           : String renames ASIS_Line_Terminator;
   Standard_GCC : constant String_Access :=
     GNAT.OS_Lib.Locate_Exec_On_Path ("gcc");

   -----------------
   -- Create_Tree --
   -----------------

   procedure Create_Tree (Source_File   :     String_Access;
                          Context       :     Context_Id;
                          Is_Predefined :     Boolean;
                          Success       : out Boolean)
   is
   begin
      if Is_Predefined then
         Compile (Source_File => Source_File,
                  Args        => (1 => GNAT_Flag),
                  Success     => Success,
                  GCC         => Gcc_To_Call (Context));
      else
         Compile (Source_File => Source_File,
                  Args        => I_Options (Context),
                  Success     => Success,
                  GCC         => Gcc_To_Call (Context));
      end if;
   exception
      when others =>
         Raise_ASIS_Failed ("A4G.GNAT_Int.Create_Tree:" & LT &
                         "  check the path and environment settings for gcc!");
   end Create_Tree;

   -------------
   -- Execute --
   -------------

   function Execute
     (Program      : String_Access;
      Args         : Argument_List;
      Compiler_Out : String := "";
      Display_Call : Boolean := A4G.A_Debug.Debug_Mode)
      return         Boolean
   is
      Success     : Boolean;
      Return_Code : Integer;

      Execute : String_Access := Program;
   begin

      if Execute = null then
         Execute := Standard_GCC;
      end if;

      if Display_Call then
         Put (Standard_Error, Execute.all);

         for J in Args'Range loop
            Put (Standard_Error, " ");
            Put (Standard_Error, Args (J).all);
         end loop;

         New_Line (Standard_Error);
      end if;

      if Execute = null then
         Ada.Exceptions.Raise_Exception
           (Program_Error'Identity,
            "A4G.GNAT_Int.Execute: Can not locate program to execute");
      end if;

      if Compiler_Out /= "" then
         GNAT.OS_Lib.Spawn
           (Execute.all,
            Args,
            Compiler_Out,
            Success,
            Return_Code);

         Success := Return_Code = 0;
      else
         GNAT.OS_Lib.Spawn (Execute.all, Args, Success);
      end if;

      return Success;
   end Execute;

   ----------------------------------------------
   -- General Interfaces between GNAT and ASIS --
   ----------------------------------------------

   function A_Time (T : Time_Stamp_Type) return Time is
      Year      : Year_Number;
      Month     : Month_Number;
      Day       : Day_Number;
      Hours     : Integer range 0 .. 23;
      Minutes   : Integer range 0 .. 59;
      Seconds   : Integer range 0 .. 59;
      Day_Time  : Day_Duration;
   begin
      Split_Time_Stamp
        (TS      => T,
         Year    => Nat (Year),
         Month   => Nat (Month),
         Day     => Nat (Day),
         Hour    => Nat (Hours),
         Minutes => Nat (Minutes),
         Seconds => Nat (Seconds));

      Day_Time := Duration (Seconds + 60 * Minutes + 3600 * Hours);

      return Time_Of (Year, Month, Day, Day_Time);
   end A_Time;

   --------------------------------
   -- Tree_In_With_Version_Check --
   --------------------------------

   procedure Tree_In_With_Version_Check
     (Desc    : File_Descriptor;
      Cont    : Context_Id;
      Success : out Boolean)
   is
      Cont_Mode   : constant Context_Mode := Context_Processing_Mode (Cont);
      File_Closed :          Boolean      := False;
      ASIS_GNAT_V : constant String       := Gnatvsn.Gnat_Version_String;
      First_A_Idx :          Natural      := ASIS_GNAT_V'First;
      Last_A_Idx  :          Natural;
      First_T_Idx :          Natural;
      Last_T_Idx  :          Natural;
   begin
      Success := False;

      Tree_IO.Tree_Read_Initialize (Desc);

      Opt.Tree_Read;

      --  GNAT/ASIS version check first

      if Tree_ASIS_Version_Number /= Tree_IO.ASIS_Version_Number then
         Close (Desc, File_Closed);
         Ada.Exceptions.Raise_Exception
           (Program_Error'Identity, "Inconsistent versions of GNAT and ASIS");
      end if;

      --  Check that ASIS Pro uses the tree created by GNAT Pro

      First_T_Idx := Tree_Version_String'First;

      if ASIS_GNAT_V (First_A_Idx  .. First_A_Idx + 2) = "Pro"
         and then Tree_Version_String (First_T_Idx  .. First_T_Idx + 2) /=
                  "Pro"
      then
         Close (Desc, File_Closed);
         Ada.Exceptions.Raise_Exception
           (Program_Error'Identity, "ASIS Pro can be used with GNAT Pro only");
      end if;

      if Strong_Version_Check then
         --  We check only the dates here!
         First_A_Idx :=
           Index (Source  => ASIS_GNAT_V,
                  Pattern => "(") + 1;

         First_T_Idx :=
           Index (Source  => Tree_Version_String.all,
                  Pattern => "(") + 1;

         Last_A_Idx := Index (Source  => ASIS_GNAT_V,
                     Pattern => ")") - 1;

         if Index (Source  => ASIS_GNAT_V, Pattern => "-") /= 0 then
            Last_A_Idx := Index (Source  => ASIS_GNAT_V,
                                 Pattern => "-") - 1;
         end if;

         Last_T_Idx := Index (Source  => Tree_Version_String.all,
                              Pattern => ")") - 1;

         if Index (Source  => Tree_Version_String.all, Pattern => "-") /=
            0
         then
            Last_T_Idx :=
              Index (Source  => Tree_Version_String.all,
                     Pattern => "-") - 1;
         end if;

         if ASIS_GNAT_V (First_A_Idx .. Last_A_Idx) /=
            Tree_Version_String (First_T_Idx .. Last_T_Idx)
         then
            Close (Desc, File_Closed);
            Ada.Exceptions.Raise_Exception
              (Program_Error'Identity,
               "Inconsistent versions of GNAT [" & Tree_Version_String.all &
               "] and ASIS [" & ASIS_GNAT_V & ']');
         end if;

      end if;

      --  Check if we are in Ada 2012 mode and need aspects...

--      if Opt.Ada_Version_Config = Ada_2012 then
--         --  For now, reading aspects is protected by the debug '.A' flag
--         Debug.Debug_Flag_Dot_AA := True;
--      end if;

      if Operating_Mode /= Check_Semantics then

         if Cont_Mode  = One_Tree then
            --  If in one-tree mode we can not read the only tree we have,
            --  there is no reason to continue, so raising an exception
            --  is the only choice:

            Close (Desc, File_Closed);

            --  We did not check File_Closed here, because the fact that the
            --  tree is not compile-only seems to be more important for ASIS

            Set_Error_Status
              (Status    => Asis.Errors.Use_Error,
               Diagnosis => "Asis.Ada_Environments.Open:"
               &  ASIS_Line_Terminator
               & "tree file "
               & Base_Name (A_Name_Buffer (1 .. A_Name_Len))
               & " is not compile-only");

            raise ASIS_Failed;

         elsif Cont_Mode = N_Trees
           or else
               Cont_Mode = All_Trees
         then

            --  no need to read the rest of this tree file, but
            --  we can continue even if we can not read some trees...

            ASIS_Warning
              (Message => "Asis.Ada_Environments.Open: "
               &  ASIS_Line_Terminator
               & "tree file "
               & Base_Name (A_Name_Buffer (1 .. A_Name_Len))
               & " is not compile-only, ignored",
               Error   => Asis.Errors.Use_Error);
         end if;

         --  debug stuff...

         if (Debug_Flag_O    or else
             Debug_Lib_Model or else
             Debug_Mode)
            and then
             Cont_Mode /= One_Tree and then
             Cont_Mode /= N_Trees
         then
            Put (Standard_Error, "The tree file ");
            Put (Standard_Error, Base_Name (A_Name_Buffer (1 .. A_Name_Len)));
            Put (Standard_Error, " is not compile-only");
            New_Line (Standard_Error);
         end if;
      else
         Atree.Tree_Read;
         Elists.Tree_Read;
         Fname.Tree_Read;
         Lib.Tree_Read;
         Namet.Tree_Read;
         Nlists.Tree_Read;
         Sem_Aux.Tree_Read;
         Sinput.Tree_Read;
         Stand.Tree_Read;
         Stringt.Tree_Read;
         Uintp.Tree_Read;
         Urealp.Tree_Read;
         Repinfo.Tree_Read;
         Aspects.Tree_Read;

         Csets.Initialize;

         --  debug stuff...
         if Debug_Flag_O    or else
            Debug_Lib_Model or else
            Debug_Mode
         then
            Put (Standard_Error, "The tree file ");
            Put (Standard_Error, Base_Name (A_Name_Buffer (1 .. A_Name_Len)));
            Put (Standard_Error, " is OK");
            New_Line (Standard_Error);
         end if;

         Success := True;
      end if;

      Close (Desc, File_Closed);

      if not File_Closed then
         Raise_ASIS_Failed
           (Diagnosis => "Asis.Ada_Environments.Open: "               &
                         "Can not close tree file: "                  &
                          Base_Name (A_Name_Buffer (1 .. A_Name_Len)) &
                          ASIS_Line_Terminator                        &
                          "disk is full or file may be used by other program",
            Stat      => Asis.Errors.Data_Error);
      end if;

   exception
      when Tree_IO.Tree_Format_Error =>
         Close (Desc, File_Closed);

         Ada.Exceptions.Raise_Exception
           (Program_Error'Identity, "Inconsistent versions of GNAT and ASIS");

   end Tree_In_With_Version_Check;

end A4G.GNAT_Int;

Add the ASIS file $i

Add the ASIS file $i


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

with Util.Beans.Objects;
with Util.Beans.Objects.Time;
with Util.Serialize.Mappers.Record_Mapper;
with Util.Http.Rest;
package body Security.Auth.OAuth.Facebook is

   --
   TIME_SHIFT : constant Duration := 12 * 3600.0;

   type Token_Info_Field_Type is (FIELD_APP_ID, FIELD_IS_VALID,
                                  FIELD_EXPIRES, FIELD_ISSUED_AT,
                                  FIELD_USER_ID, FIELD_EMAIL, FIELD_FIRST_NAME,
                                  FIELD_LAST_NAME, FIELD_NAME, FIELD_LOCALE, FIELD_GENDER);

   type Token_Info is record
      App_Id     : Ada.Strings.Unbounded.Unbounded_String;
      Is_Valid   : Boolean := False;
      Expires    : Ada.Calendar.Time;
      Issued     : Ada.Calendar.Time;
      User_Id    : Ada.Strings.Unbounded.Unbounded_String;
      Email      : Ada.Strings.Unbounded.Unbounded_String;
      Name       : Ada.Strings.Unbounded.Unbounded_String;
      First_Name : Ada.Strings.Unbounded.Unbounded_String;
      Last_Name  : Ada.Strings.Unbounded.Unbounded_String;
      Locale     : Ada.Strings.Unbounded.Unbounded_String;
      Gender     : Ada.Strings.Unbounded.Unbounded_String;
   end record;
   type Token_Info_Access is access all Token_Info;

   procedure Set_Member (Into  : in out Token_Info;
                         Field : in Token_Info_Field_Type;
                         Value : in Util.Beans.Objects.Object);

   procedure Set_Member (Into  : in out Token_Info;
                         Field : in Token_Info_Field_Type;
                         Value : in Util.Beans.Objects.Object) is
   begin
      case Field is
         when FIELD_APP_ID =>
            Into.App_Id := Util.Beans.Objects.To_Unbounded_String (Value);

         when FIELD_IS_VALID =>
            Into.Is_Valid := Util.Beans.Objects.To_Boolean (Value);

         when FIELD_EXPIRES =>
            Into.Expires := Util.Beans.Objects.Time.To_Time (Value);

         when FIELD_ISSUED_AT =>
            Into.Issued := Util.Beans.Objects.Time.To_Time (Value);

         when FIELD_USER_ID =>
            Into.User_Id := Util.Beans.Objects.To_Unbounded_String (Value);

         when FIELD_EMAIL =>
            Into.Email := Util.Beans.Objects.To_Unbounded_String (Value);

         when FIELD_NAME =>
            Into.Name := Util.Beans.Objects.To_Unbounded_String (Value);

         when FIELD_FIRST_NAME =>
            Into.First_Name := Util.Beans.Objects.To_Unbounded_String (Value);

         when FIELD_LAST_NAME =>
            Into.Last_Name := Util.Beans.Objects.To_Unbounded_String (Value);

         when FIELD_LOCALE =>
            Into.Locale := Util.Beans.Objects.To_Unbounded_String (Value);

         when FIELD_GENDER =>
            Into.Gender := Util.Beans.Objects.To_Unbounded_String (Value);

      end case;
   end Set_Member;

   package Token_Info_Mapper is
      new Util.Serialize.Mappers.Record_Mapper (Element_Type        => Token_Info,
                                                Element_Type_Access => Token_Info_Access,
                                                Fields              => Token_Info_Field_Type,
                                                Set_Member          => Set_Member);

   procedure Get_Token_Info is
     new Util.Http.Rest.Rest_Get (Element_Mapper => Token_Info_Mapper);

   Token_Info_Map : aliased Token_Info_Mapper.Mapper;

   --  ------------------------------
   --  Verify the OAuth access token and retrieve information about the user.
   --  ------------------------------
   overriding
   procedure Verify_Access_Token (Realm   : in Manager;
                                  Assoc   : in Association;
                                  Request : in Parameters'Class;
                                  Token   : in Security.OAuth.Clients.Access_Token_Access;
                                  Result  : in out Authentication) is
      use type Ada.Calendar.Time;

      T    : constant String := Token.Get_Name;
      Info : aliased Token_Info;
      Now  : constant Ada.Calendar.Time := Ada.Calendar.Clock;
   begin
      Get_Token_Info ("https://graph.facebook.com/debug_token?access_token=" & T
                      & "&input_token=" & T,
                      Token_Info_Map'Access,
                      "/data",
                      Info'Unchecked_Access);
      if not Info.Is_Valid then
         Set_Result (Result, INVALID_SIGNATURE, "invalid access token returned");

      elsif Info.Issued + TIME_SHIFT < Now then
         Set_Result (Result, INVALID_SIGNATURE, "the access token issued more than 1 hour ago");

      elsif Info.Expires + TIME_SHIFT < Now then
         Set_Result (Result, INVALID_SIGNATURE, "the access token has expored");

      elsif Length (Info.User_Id) = 0 then
         Set_Result (Result, INVALID_SIGNATURE, "the access token refers to an empty user_id");

      elsif Info.App_Id /= Realm.App.Get_Application_Identifier then
         Set_Result (Result, INVALID_SIGNATURE,
                     "the access token was granted for another application");

      else
         Result.Identity := To_Unbounded_String ("https://graph.facebook.com/");
         Append (Result.Identity, Info.User_Id);
         Result.Claimed_Id := Result.Identity;

         Get_Token_Info ("https://graph.facebook.com/" & To_String (Info.User_Id)
                           & "?access_token=" & T,
                         Token_Info_Map'Access,
                         "",
                         Info'Unchecked_Access);

         Result.Email      := Info.Email;
         Result.Full_Name  := Info.Name;
         Result.First_Name := Info.First_Name;
         Result.Last_Name  := Info.Last_Name;
         Result.Language   := Info.Locale;
         Result.Gender     := Info.Gender;
         Set_Result (Result, AUTHENTICATED, "authenticated");
      end if;
   end Verify_Access_Token;

begin
   Token_Info_Map.Add_Mapping ("app_id", FIELD_APP_ID);
   Token_Info_Map.Add_Mapping ("expires_at", FIELD_EXPIRES);
   Token_Info_Map.Add_Mapping ("issued_at", FIELD_ISSUED_AT);
   Token_Info_Map.Add_Mapping ("is_valid", FIELD_IS_VALID);
   Token_Info_Map.Add_Mapping ("user_id", FIELD_USER_ID);
   Token_Info_Map.Add_Mapping ("email", FIELD_EMAIL);
   Token_Info_Map.Add_Mapping ("name", FIELD_NAME);
   Token_Info_Map.Add_Mapping ("first_name", FIELD_FIRST_NAME);
   Token_Info_Map.Add_Mapping ("last_name", FIELD_LAST_NAME);
   Token_Info_Map.Add_Mapping ("locale", FIELD_LOCALE);
   Token_Info_Map.Add_Mapping ("gender", FIELD_GENDER);
end Security.Auth.OAuth.Facebook;

Implement the Facebook authentication

Implement the Facebook authentication


-----------------------------------------------------------------------
--  Util.Serialize.Mappers.Record_Mapper -- Mapper for record types
--  Copyright (C) 2010, 2011 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Util.Beans.Objects;
with Util.Serialize.IO;
generic
   type Element_Type (<>) is limited private;
   type Element_Type_Access is access all Element_Type;
   type Fields is (<>);

   --  The Set_Member procedure will be called by the mapper when a mapping associated
   --  with Field is recognized.  The Value holds the value that was extracted
   --  according to the mapping.  The Set_Member procedure should save in the target
   --  object Into the value.  If an error is detected, the procedure can raise the
   --  Util.Serialize.Mappers.Field_Error exception.  The exception message will be
   --  reported by the IO reader as an error.
   with procedure Set_Member (Into   : in out Element_Type;
                              Field  : in Fields;
                              Value  : in Util.Beans.Objects.Object);

   --  Adding a second function/procedure as generic parameter makes the
   --  Vector_Mapper generic package fail to instantiate a valid package.
   --  The failure occurs in Vector_Mapper in the 'with package Element_Mapper' instantiation.
   --
--        with function Get_Member (From  : in Element_Type;
--                                  Field : in Fields) return Util.Beans.Objects.Object;
package Util.Serialize.Mappers.Record_Mapper is

   type Get_Member_Access is
     access function (From  : in Element_Type;
                      Field : in Fields) return Util.Beans.Objects.Object;

   --  Procedure to give access to the Element_Type object from the context.
   type Process_Object is not null
   access procedure (Ctx     : in out Util.Serialize.Contexts.Context'Class;
                     Attr    : in Mapping'Class;
                     Value   : in Util.Beans.Objects.Object;
                     Process : not null
                     access procedure (Attr  : in Mapping'Class;
                                       Item  : in out Element_Type;
                                       Value : in Util.Beans.Objects.Object));

   type Proxy_Object is not null
   access procedure (Attr    : in Mapping'Class;
                     Element : in out Element_Type;
                     Value   : in Util.Beans.Objects.Object);

   --  Set the attribute member described by the Attr mapping
   --  into the value passed in Element.  This operation will call
   --  the package parameter function of the same name.
   procedure Set_Member (Attr    : in Mapping'Class;
                         Element : in out Element_Type;
                         Value   : in Util.Beans.Objects.Object);

   --  -----------------------
   --  Data context
   --  -----------------------
   --  Data context to get access to the target element.
   type Element_Data is new Util.Serialize.Contexts.Data with private;
   type Element_Data_Access is access all Element_Data'Class;

   --  Get the element object.
   function Get_Element (Data : in Element_Data) return Element_Type_Access;

   --  Set the element object.  When Release is set, the element Element
   --  will be freed when the reader context is deleted (by Finalize).
   procedure Set_Element (Data    : in out Element_Data;
                          Element : in Element_Type_Access;
                          Release : in Boolean := False);

   --  Finalize the object when it is removed from the reader context.
   --  If the Release parameter was set, the target element will be freed.
   overriding
   procedure Finalize (Data : in out Element_Data);

   --  -----------------------
   --  Record mapper
   --  -----------------------
   type Mapper is new Util.Serialize.Mappers.Mapper with private;
   type Mapper_Access is access all Mapper'Class;

   --  Execute the mapping operation on the object associated with the current context.
   --  The object is extracted from the context and the Execute operation is called.
   procedure Execute (Handler : in Mapper;
                      Map     : in Mapping'Class;
                      Ctx     : in out Util.Serialize.Contexts.Context'Class;
                      Value   : in Util.Beans.Objects.Object);

   --  Add a mapping for setting a member.  When the attribute rule defined by Path
   --  is matched, the Set_Member procedure will be called with the value and the
   --  Field identification.
   procedure Add_Mapping (Into  : in out Mapper;
                          Path  : in String;
                          Field : in Fields);

   --  Add a mapping associated with the path and described by a mapper object.
   --  The Proxy procedure is in charge of giving access to the target
   --  object used by the Map mapper.
   procedure Add_Mapping (Into  : in out Mapper;
                          Path  : in String;
                          Map   : in Util.Serialize.Mappers.Mapper_Access;
                          Proxy : in Proxy_Object);

   --  Clone the Handler instance and get a copy of that single object.
   overriding
   function Clone (Handler : in Mapper) return Util.Serialize.Mappers.Mapper_Access;

   --
   procedure Bind (Into    : in out Mapper;
                   Getter  : in Get_Member_Access);

   procedure Bind (Into    : in out Mapper;
                   From    : in Mapper_Access);

   function Get_Getter (From : in Mapper) return Get_Member_Access;

   --  Set the element in the context.  When Release is set, the element Element
   --  will be freed when the reader context is deleted (by Finalize).
   procedure Set_Context (Ctx     : in out Util.Serialize.Contexts.Context'Class;
                          Element : in Element_Type_Access;
                          Release : in Boolean := False);

   --  Build a default mapping based on the Fields enumeration.
   --  The enumeration name is used for the mapping name with the optional FIELD_
   --  prefix stripped.
   procedure Add_Default_Mapping (Into : in out Mapper);

   --  Write the element on the stream using the mapper description.
   procedure Write (Handler : in Mapper;
                    Stream  : in out Util.Serialize.IO.Output_Stream'Class;
                    Element : in Element_Type);

   --  Write the element on the stream using the mapper description.
   procedure Write (Handler : in Util.Serialize.Mappers.Mapper'Class;
                    Getter  : in Get_Member_Access;
                    Stream  : in out Util.Serialize.IO.Output_Stream'Class;
                    Element : in Element_Type);

private

   type Element_Data is new Util.Serialize.Contexts.Data with record
      Element : Element_Type_Access;
      Release : Boolean;
   end record;

   type Mapper is new Util.Serialize.Mappers.Mapper with record
      Execute    : Proxy_Object := Set_Member'Access;
      Get_Member : Get_Member_Access;
   end record;

   type Attribute_Mapping is new Mapping with record
      Index   : Fields;
   end record;
   type Attribute_Mapping_Access is access all Attribute_Mapping'Class;

   procedure Set_Member (Attr    : in Attribute_Mapping;
                         Element : in out Element_Type;
                         Value   : in Util.Beans.Objects.Object);

   type Proxy_Mapper is new Mapper with null record;
   type Proxy_Mapper_Access is access all Proxy_Mapper'Class;

   --  Find the mapper associated with the given name.
   --  Returns null if there is no mapper.
   overriding
   function Find_Mapper (Controller : in Proxy_Mapper;
                         Name       : in String;
                         Attribute  : in Boolean := False)
                         return Util.Serialize.Mappers.Mapper_Access;

end Util.Serialize.Mappers.Record_Mapper;

-----------------------------------------------------------------------
--  Util.Serialize.Mappers.Record_Mapper -- Mapper for record types
--  Copyright (C) 2010, 2011, 2012 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Util.Beans.Objects;
with Util.Serialize.IO;
generic
   type Element_Type (<>) is limited private;
   type Element_Type_Access is access all Element_Type;
   type Fields is (<>);

   --  The Set_Member procedure will be called by the mapper when a mapping associated
   --  with Field is recognized.  The Value holds the value that was extracted
   --  according to the mapping.  The Set_Member procedure should save in the target
   --  object Into the value.  If an error is detected, the procedure can raise the
   --  Util.Serialize.Mappers.Field_Error exception.  The exception message will be
   --  reported by the IO reader as an error.
   with procedure Set_Member (Into   : in out Element_Type;
                              Field  : in Fields;
                              Value  : in Util.Beans.Objects.Object);

   --  Adding a second function/procedure as generic parameter makes the
   --  Vector_Mapper generic package fail to instantiate a valid package.
   --  The failure occurs in Vector_Mapper in the 'with package Element_Mapper' instantiation.
   --
--        with function Get_Member (From  : in Element_Type;
--                                  Field : in Fields) return Util.Beans.Objects.Object;
package Util.Serialize.Mappers.Record_Mapper is

   type Get_Member_Access is
     access function (From  : in Element_Type;
                      Field : in Fields) return Util.Beans.Objects.Object;

   --  Procedure to give access to the Element_Type object from the context.
   type Process_Object is not null
   access procedure (Ctx     : in out Util.Serialize.Contexts.Context'Class;
                     Attr    : in Mapping'Class;
                     Value   : in Util.Beans.Objects.Object;
                     Process : not null
                     access procedure (Attr  : in Mapping'Class;
                                       Item  : in out Element_Type;
                                       Value : in Util.Beans.Objects.Object));

   type Proxy_Object is not null
   access procedure (Attr    : in Mapping'Class;
                     Element : in out Element_Type;
                     Value   : in Util.Beans.Objects.Object);

   --  Set the attribute member described by the Attr mapping
   --  into the value passed in Element.  This operation will call
   --  the package parameter function of the same name.
   procedure Set_Member (Attr    : in Mapping'Class;
                         Element : in out Element_Type;
                         Value   : in Util.Beans.Objects.Object);

   --  -----------------------
   --  Data context
   --  -----------------------
   --  Data context to get access to the target element.
   type Element_Data is new Util.Serialize.Contexts.Data with private;
   type Element_Data_Access is access all Element_Data'Class;

   --  Get the element object.
   function Get_Element (Data : in Element_Data) return Element_Type_Access;

   --  Set the element object.  When Release is set, the element Element
   --  will be freed when the reader context is deleted (by Finalize).
   procedure Set_Element (Data    : in out Element_Data;
                          Element : in Element_Type_Access;
                          Release : in Boolean := False);

   --  Finalize the object when it is removed from the reader context.
   --  If the Release parameter was set, the target element will be freed.
   overriding
   procedure Finalize (Data : in out Element_Data);

   --  -----------------------
   --  Record mapper
   --  -----------------------
   type Mapper is new Util.Serialize.Mappers.Mapper with private;
   type Mapper_Access is access all Mapper'Class;

   --  Execute the mapping operation on the object associated with the current context.
   --  The object is extracted from the context and the Execute operation is called.
   procedure Execute (Handler : in Mapper;
                      Map     : in Mapping'Class;
                      Ctx     : in out Util.Serialize.Contexts.Context'Class;
                      Value   : in Util.Beans.Objects.Object);

   --  Add a mapping for setting a member.  When the attribute rule defined by Path
   --  is matched, the Set_Member procedure will be called with the value and the
   --  Field identification.
   procedure Add_Mapping (Into  : in out Mapper;
                          Path  : in String;
                          Field : in Fields);

   --  Add a mapping associated with the path and described by a mapper object.
   --  The Proxy procedure is in charge of giving access to the target
   --  object used by the Map mapper.
   procedure Add_Mapping (Into  : in out Mapper;
                          Path  : in String;
                          Map   : in Util.Serialize.Mappers.Mapper_Access;
                          Proxy : in Proxy_Object);

   --  Clone the Handler instance and get a copy of that single object.
   overriding
   function Clone (Handler : in Mapper) return Util.Serialize.Mappers.Mapper_Access;

   --
   procedure Bind (Into    : in out Mapper;
                   Getter  : in Get_Member_Access);

   procedure Bind (Into    : in out Mapper;
                   From    : in Mapper_Access);

   function Get_Getter (From : in Mapper) return Get_Member_Access;

   --  Set the element in the context.  When Release is set, the element Element
   --  will be freed when the reader context is deleted (by Finalize).
   procedure Set_Context (Ctx     : in out Util.Serialize.Contexts.Context'Class;
                          Element : in Element_Type_Access;
                          Release : in Boolean := False);

   --  Build a default mapping based on the Fields enumeration.
   --  The enumeration name is used for the mapping name with the optional FIELD_
   --  prefix stripped.
   procedure Add_Default_Mapping (Into : in out Mapper);

   --  Write the element on the stream using the mapper description.
   procedure Write (Handler : in Mapper;
                    Stream  : in out Util.Serialize.IO.Output_Stream'Class;
                    Element : in Element_Type);

   --  Write the element on the stream using the mapper description.
   procedure Write (Handler : in Util.Serialize.Mappers.Mapper'Class;
                    Getter  : in Get_Member_Access;
                    Stream  : in out Util.Serialize.IO.Output_Stream'Class;
                    Element : in Element_Type);

private

   type Element_Data is new Util.Serialize.Contexts.Data with record
      Element : Element_Type_Access;
      Release : Boolean;
   end record;

   type Mapper is new Util.Serialize.Mappers.Mapper with record
      Execute    : Proxy_Object := Set_Member'Access;
      Get_Member : Get_Member_Access;
   end record;

   type Attribute_Mapping is new Mapping with record
      Index   : Fields;
   end record;
   type Attribute_Mapping_Access is access all Attribute_Mapping'Class;

   procedure Set_Member (Attr    : in Attribute_Mapping;
                         Element : in out Element_Type;
                         Value   : in Util.Beans.Objects.Object);

   type Proxy_Mapper is new Mapper with null record;
   type Proxy_Mapper_Access is access all Proxy_Mapper'Class;

   --  Find the mapper associated with the given name.
   --  Returns null if there is no mapper.
   overriding
   function Find_Mapper (Controller : in Proxy_Mapper;
                         Name       : in String;
                         Attribute  : in Boolean := False)
                         return Util.Serialize.Mappers.Mapper_Access;

end Util.Serialize.Mappers.Record_Mapper;

Fix header

Fix header


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

with Ada.Directories;
with Util.Test_Caller;

with MAT.Readers.Files;
package body MAT.Targets.Tests is

   use Util.Tests;

   package Caller is new Util.Test_Caller (Test, "Files");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test MAT.Targets.Read_File",
                       Test_Read_File'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test reading a file into a string
   --  Reads this ada source file and checks we have read it correctly
   --  ------------------------------
   procedure Test_Read_File (T : in out Test) is
      Path   : constant String := Util.Tests.Get_Test_Path ("regtests/files/file-v1.dat");
      Target : MAT.Targets.Target_Type;
      Reader : MAT.Readers.Files.File_Reader_Type;
   begin
      Target.Initialize (Reader);
      Reader.Open (Path);
      Reader.Read_All;
   end Test_Read_File;

end MAT.Targets.Tests;

Implement a simple unit test for MAT.Targets package


-----------------------------------------------------------------------
--  druss-commands-devices -- Print information about the devices
--  Copyright (C) 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.Properties;
with Bbox.API;
with Druss.Gateways;
with Ada.Strings.Unbounded;
package body Druss.Commands.Ping is

   use Ada.Strings.Unbounded;

   --  ------------------------------
   --  Execute the wifi 'status' command to print the Wifi current status.
   --  ------------------------------
   procedure Do_Ping (Command   : in Command_Type;
                      Args      : in Argument_List'Class;
                      Context   : in out Context_Type) is
      pragma Unreferenced (Command);

      Console : constant Druss.Commands.Consoles.Console_Access := Context.Console;

      procedure Box_Status (Gateway : in out Druss.Gateways.Gateway_Type) is
         Box  : Bbox.API.Client_Type;

         procedure Ping_Device (Manager : in Util.Properties.Manager;
                                Name    : in String) is
            Link : constant String := Manager.Get (Name & ".link", "");
            Id   : constant String := Manager.Get (Name & ".id", "");
         begin
            if Manager.Get (Name & ".active", "") = "0" then
               return;
            end if;
            Box.Post ("hosts/" & Id, "action=ping");
         end Ping_Device;

      begin
         if Ada.Strings.Unbounded.Length (Gateway.Passwd) = 0 then
            return;
         end if;
         Gateway.Refresh;
         Box.Set_Server (To_String (Gateway.IP));
         Box.Login (To_String (Gateway.Passwd));

         Bbox.API.Iterate (Gateway.Hosts, "hosts.list", Ping_Device'Access);
      end Box_Status;

   begin
      Console.Start_Title;
      Console.Print_Title (F_BBOX_IP_ADDR, "Bbox IP", 16);
      Console.Print_Title (F_IP_ADDR, "Device IP", 16);
      Console.Print_Title (F_ETHERNET, "Ethernet", 20);
      Console.Print_Title (F_HOSTNAME, "Hostname", 28);
      Console.Print_Title (F_DEVTYPE, "Type", 6);
      --  Console.Print_Title (F_ACTIVE, "Active", 8);
      Console.Print_Title (F_LINK, "Link", 18);
      Console.End_Title;
      Druss.Gateways.Iterate (Context.Gateways, Gateways.ITER_ENABLE, Box_Status'Access);
   end Do_Ping;

   --  Execute a status command to report information about the Bbox.
   overriding
   procedure Execute (Command   : in Command_Type;
                      Name      : in String;
                      Args      : in Argument_List'Class;
                      Context   : in out Context_Type) is
      pragma Unreferenced (Name);
   begin
      Command.Do_Ping (Args, Context);
   end Execute;

   --  Write the help associated with the command.
   overriding
   procedure Help (Command   : in Command_Type;
                   Context   : in out Context_Type) is
      pragma Unreferenced (Command);
      Console : constant Druss.Commands.Consoles.Console_Access := Context.Console;
   begin
      Console.Notice (N_HELP, "devices: Print information about the devices");
      Console.Notice (N_HELP, "Usage: devices [options]");
      Console.Notice (N_HELP, "");
   end Help;

end Druss.Commands.Ping;

Implement the ping command to ask the bbox to ping the known devices