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

   use type ASF.Routes.Route_Type_Access;

   procedure Free is
     new Ada.Unchecked_Deallocation (Object => ASF.Routes.Servlets.Faces.Faces_Route_Type'Class,
                                     Name   => ASF.Routes.Servlets.Faces.Faces_Route_Type_Access);

   function Find_Servlet (Container : in Servlet_Registry_Access;
                          View      : in String)
                          return ASF.Servlets.Servlet_Access is
      Disp  : constant Request_Dispatcher := Container.Get_Request_Dispatcher (View);
      Route : constant ASF.Routes.Route_Type_Access := Disp.Context.Get_Route;
   begin
      if Route = null then
         raise Util.Serialize.Mappers.Field_Error with "No servlet mapped to view " & View;
      end if;
      if not (Route.all in ASF.Routes.Servlets.Servlet_Route_Type'Class) then
         raise Util.Serialize.Mappers.Field_Error with "View " & View & " not mapped to a servlet";
      end if;
      return ASF.Routes.Servlets.Servlet_Route_Type'Class (Route.all).Servlet;
   end Find_Servlet;

   --  ------------------------------
   --  Save in the servlet config object the value associated with the given field.
   --  When the URL_MAPPING, URL_PATTERN, VIEW_ID field
   --  is reached, insert the new configuration rule in the servlet registry.
   --  ------------------------------
   procedure Set_Member (N     : in out Servlet_Config;
                         Field : in Servlet_Fields;
                         Value : in Util.Beans.Objects.Object) is
      use Util.Beans.Objects;

      Route : ASF.Routes.Servlets.Faces.Faces_Route_Type_Access;
   begin
      case Field is
         when URL_PATTERN =>
            N.URL_Pattern := Value;

         when VIEW_ID =>
            N.View_Id := Value;

         when URL_MAPPING =>
            declare
               View    : constant String := To_String (N.View_Id);
               Servlet : constant ASF.Servlets.Servlet_Access := Find_Servlet (N.Handler, View);
            begin
               Route := new ASF.Routes.Servlets.Faces.Faces_Route_Type;
               Route.View    := To_Unbounded_String (View);
               Route.Servlet := Servlet;
               N.Handler.Add_Route (Pattern   => To_String (N.URL_Pattern),
                                    To        => Route.all'Access,
                                    ELContext => N.Context.all);
            exception
               when others =>
                  Free (Route);
                  raise;
            end;
      end case;
   end Set_Member;

   SMapper : aliased Servlet_Mapper.Mapper;

   --  ------------------------------
   --  Setup the XML parser to read the servlet and mapping rules <b>url-mapping</b>.
   --  ------------------------------
   package body Reader_Config is
   begin
      Reader.Add_Mapping ("faces-config", SMapper'Access);
      Reader.Add_Mapping ("module", SMapper'Access);
      Reader.Add_Mapping ("web-app", SMapper'Access);
      Config.Handler := Handler;
      Config.Context := Context;
      Servlet_Mapper.Set_Context (Reader, Config'Unchecked_Access);
   end Reader_Config;

begin
   SMapper.Add_Mapping ("url-mapping", URL_MAPPING);
   SMapper.Add_Mapping ("url-mapping/pattern", URL_PATTERN);
   SMapper.Add_Mapping ("url-mapping/view-id", VIEW_ID);
end ASF.Servlets.Faces.Mappers;

Read the faces extension configuration to add support for pretty URL with URL parameter injection


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

with Ada.Directories;
with Util.Test_Caller;
package body Util.Files.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 Util.Files.Read_File",
                       Test_Read_File'Access);
      Caller.Add_Test (Suite, "Test Util.Files.Read_File (missing)",
                       Test_Read_File'Access);
      Caller.Add_Test (Suite, "Test Util.Files.Read_File (truncate)",
                       Test_Read_File'Access);
      Caller.Add_Test (Suite, "Test Util.Files.Write_File",
                       Test_Write_File'Access);
      Caller.Add_Test (Suite, "Test Util.Files.Iterate_Path",
                       Test_Iterate_Path'Access);
      Caller.Add_Test (Suite, "Test Util.Files.Find_File_Path",
                       Test_Find_File_Path'Access);
      Caller.Add_Test (Suite, "Test Util.Files.Compose_Path",
                       Test_Compose_Path'Access);
      Caller.Add_Test (Suite, "Test Util.Files.Get_Relative_Path",
                       Test_Get_Relative_Path'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
      Result : Unbounded_String;
   begin
      Read_File (Path => "regtests/util-files-tests.adb", Into => Result);
      T.Assert (Index (Result, "Util.Files.Tests") > 0,
                "Content returned by Read_File is not correct");
      T.Assert (Index (Result, "end Util.Files.Tests;") > 0,
                "Content returned by Read_File is not correct");
   end Test_Read_File;

   procedure Test_Read_File_Missing (T : in out Test) is
      Result : Unbounded_String;

      pragma Unreferenced (Result);
   begin
      Read_File (Path => "regtests/files-test--util.adb", Into => Result);
      T.Assert (False, "No exception raised");
   exception
      when others =>
         null;
   end Test_Read_File_Missing;

   procedure Test_Read_File_Truncate (T : in out Test) is
      Result : Unbounded_String;
   begin
      Read_File (Path => "regtests/util-files-tests.adb", Into => Result,
                 Max_Size => 50);
      Assert_Equals (T, Length (Result), 50,
                     "Read_File did not truncate correctly");
      T.Assert (Index (Result, "Apache License") > 0,
                "Content returned by Read_File is not correct");
   end Test_Read_File_Truncate;

   --  ------------------------------
   --  Check writing a file
   --  ------------------------------
   procedure Test_Write_File (T : in out Test) is
      Path   : constant String := Util.Tests.Get_Test_Path ("test-write.txt");
      Content : constant String := "Testing Util.Files.Write_File" & ASCII.LF;
      Result : Unbounded_String;
   begin
      Write_File (Path => Path, Content => Content);
      Read_File (Path => Path, Into => Result);
      Assert_Equals (T, To_String (Result), Content,
                     "Invalid content written or read");
   end Test_Write_File;

   --  ------------------------------
   --  Check Find_File_Path
   --  ------------------------------
   procedure Test_Find_File_Path (T : in out Test) is
      Dir   : constant String := Util.Tests.Get_Path ("regtests");
      Paths : constant String := ".;" & Dir;
   begin
      declare
         P : constant String := Util.Files.Find_File_Path ("test.properties", Paths);
      begin
         Assert_Equals (T, Dir & "/test.properties", P,
                        "Invalid path returned");
      end;
      Assert_Equals (T, "blablabla.properties",
                     Util.Files.Find_File_Path ("blablabla.properties", Paths));
   end Test_Find_File_Path;

   --  ------------------------------
   --  Check Iterate_Path
   --  ------------------------------
   procedure Test_Iterate_Path (T : in out Test) is
      procedure Check_Path (Dir : in String;
                            Done : out Boolean);

      Last : Unbounded_String;

      procedure Check_Path (Dir : in String;
                            Done : out Boolean) is
      begin
         if Dir = "a" or Dir = "bc" or Dir = "de" then
            Done := False;
         else
            Done := True;
            Last := To_Unbounded_String (Dir);
         end if;
      end Check_Path;

   begin
      Iterate_Path ("a;bc;de;f", Check_Path'Access);
      Assert_Equals (T, "f", Last, "Invalid last path");

      Iterate_Path ("de;bc;de;b", Check_Path'Access);
      Assert_Equals (T, "b", Last, "Invalid last path");

   end Test_Iterate_Path;

   --  ------------------------------
   --  Test the Compose_Path operation
   --  ------------------------------
   procedure Test_Compose_Path (T : in out Test) is
   begin
      Assert_Equals (T, "src/os-none",
                     Compose_Path ("src;regtests", "os-none"),
                     "Invalid path composition");
      Assert_Equals (T, "regtests/bundles",
                     Compose_Path ("src;regtests", "bundles"),
                     "Invalid path composition");
      if Ada.Directories.Exists ("/usr/bin") then
         Assert_Equals (T, "/usr/bin;/usr/local/bin;/usr/bin",
                        Compose_Path ("/usr;/usr/local;/usr", "bin"),
                        "Invalid path composition");
      end if;
   end Test_Compose_Path;

   --  ------------------------------
   --  Test the Get_Relative_Path operation.
   --  ------------------------------
   procedure Test_Get_Relative_Path (T : in out Test) is
   begin
      Assert_Equals (T, "../util",
                     Get_Relative_Path ("/home/john/src/asf", "/home/john/src/util"),
                     "Invalid relative path");
      Assert_Equals (T, "../util",
                     Get_Relative_Path ("/home/john/src/asf/", "/home/john/src/util"),
                     "Invalid relative path");
      Assert_Equals (T, "../util/b",
                     Get_Relative_Path ("/home/john/src/asf", "/home/john/src/util/b"),
                     "Invalid relative path");
      Assert_Equals (T, "../as",
                     Get_Relative_Path ("/home/john/src/asf", "/home/john/src/as"),
                     "Invalid relative path");
      Assert_Equals (T, "../../",
                     Get_Relative_Path ("/home/john/src/asf", "/home/john"),
                     "Invalid relative path");
      Assert_Equals (T, "/usr/share/admin",
                     Get_Relative_Path ("/home/john/src/asf", "/usr/share/admin"),
                     "Invalid absolute path");
      Assert_Equals (T, "/home/john",
                     Get_Relative_Path ("home/john/src/asf", "/home/john"),
                     "Invalid relative path");
      Assert_Equals (T, "e",
                     Get_Relative_Path ("/home/john/src/asf", "/home/john/src/asf/e"),
                     "Invalid relative path");
      Assert_Equals (T, ".",
                     Get_Relative_Path ("/home/john/src/asf", "/home/john/src/asf/"),
                     "Invalid relative path");
   end Test_Get_Relative_Path;

end Util.Files.Tests;

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

with Ada.Directories;
with Util.Test_Caller;
package body Util.Files.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 Util.Files.Read_File",
                       Test_Read_File'Access);
      Caller.Add_Test (Suite, "Test Util.Files.Read_File (missing)",
                       Test_Read_File'Access);
      Caller.Add_Test (Suite, "Test Util.Files.Read_File (truncate)",
                       Test_Read_File'Access);
      Caller.Add_Test (Suite, "Test Util.Files.Write_File",
                       Test_Write_File'Access);
      Caller.Add_Test (Suite, "Test Util.Files.Iterate_Path",
                       Test_Iterate_Path'Access);
      Caller.Add_Test (Suite, "Test Util.Files.Find_File_Path",
                       Test_Find_File_Path'Access);
      Caller.Add_Test (Suite, "Test Util.Files.Compose_Path",
                       Test_Compose_Path'Access);
      Caller.Add_Test (Suite, "Test Util.Files.Get_Relative_Path",
                       Test_Get_Relative_Path'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
      Result : Unbounded_String;
   begin
      Read_File (Path => "regtests/util-files-tests.adb", Into => Result);
      T.Assert (Index (Result, "Util.Files.Tests") > 0,
                "Content returned by Read_File is not correct");
      T.Assert (Index (Result, "end Util.Files.Tests;") > 0,
                "Content returned by Read_File is not correct");
   end Test_Read_File;

   procedure Test_Read_File_Missing (T : in out Test) is
      Result : Unbounded_String;

      pragma Unreferenced (Result);
   begin
      Read_File (Path => "regtests/files-test--util.adb", Into => Result);
      T.Assert (False, "No exception raised");
   exception
      when others =>
         null;
   end Test_Read_File_Missing;

   procedure Test_Read_File_Truncate (T : in out Test) is
      Result : Unbounded_String;
   begin
      Read_File (Path => "regtests/util-files-tests.adb", Into => Result,
                 Max_Size => 50);
      Assert_Equals (T, Length (Result), 50,
                     "Read_File did not truncate correctly");
      T.Assert (Index (Result, "Apache License") > 0,
                "Content returned by Read_File is not correct");
   end Test_Read_File_Truncate;

   --  ------------------------------
   --  Check writing a file
   --  ------------------------------
   procedure Test_Write_File (T : in out Test) is
      Path   : constant String := Util.Tests.Get_Test_Path ("test-write.txt");
      Content : constant String := "Testing Util.Files.Write_File" & ASCII.LF;
      Result : Unbounded_String;
   begin
      Write_File (Path => Path, Content => Content);
      Read_File (Path => Path, Into => Result);
      Assert_Equals (T, To_String (Result), Content,
                     "Invalid content written or read");
   end Test_Write_File;

   --  ------------------------------
   --  Check Find_File_Path
   --  ------------------------------
   procedure Test_Find_File_Path (T : in out Test) is
      Dir   : constant String := Util.Tests.Get_Path ("regtests");
      Paths : constant String := ".;" & Dir;
   begin
      declare
         P : constant String := Util.Files.Find_File_Path ("test.properties", Paths);
      begin
         Assert_Equals (T, Dir & "/test.properties", P,
                        "Invalid path returned");
      end;
      Assert_Equals (T, "blablabla.properties",
                     Util.Files.Find_File_Path ("blablabla.properties", Paths));
   end Test_Find_File_Path;

   --  ------------------------------
   --  Check Iterate_Path
   --  ------------------------------
   procedure Test_Iterate_Path (T : in out Test) is
      procedure Check_Path (Dir : in String;
                            Done : out Boolean);

      Last : Unbounded_String;

      procedure Check_Path (Dir : in String;
                            Done : out Boolean) is
      begin
         if Dir = "a" or Dir = "bc" or Dir = "de" then
            Done := False;
         else
            Done := True;
         end if;
         Last := To_Unbounded_String (Dir);
      end Check_Path;

   begin
      Iterate_Path ("a;bc;de;f", Check_Path'Access);
      Assert_Equals (T, "f", Last, "Invalid last path");

      Iterate_Path ("de;bc;de;b", Check_Path'Access);
      Assert_Equals (T, "b", Last, "Invalid last path");

      Iterate_Path ("de;bc;de;a", Check_Path'Access, Ada.Strings.Backward);
      Assert_Equals (T, "de", Last, "Invalid last path");

   end Test_Iterate_Path;

   --  ------------------------------
   --  Test the Compose_Path operation
   --  ------------------------------
   procedure Test_Compose_Path (T : in out Test) is
   begin
      Assert_Equals (T, "src/os-none",
                     Compose_Path ("src;regtests", "os-none"),
                     "Invalid path composition");
      Assert_Equals (T, "regtests/bundles",
                     Compose_Path ("src;regtests", "bundles"),
                     "Invalid path composition");
      if Ada.Directories.Exists ("/usr/bin") then
         Assert_Equals (T, "/usr/bin;/usr/local/bin;/usr/bin",
                        Compose_Path ("/usr;/usr/local;/usr", "bin"),
                        "Invalid path composition");
      end if;
   end Test_Compose_Path;

   --  ------------------------------
   --  Test the Get_Relative_Path operation.
   --  ------------------------------
   procedure Test_Get_Relative_Path (T : in out Test) is
   begin
      Assert_Equals (T, "../util",
                     Get_Relative_Path ("/home/john/src/asf", "/home/john/src/util"),
                     "Invalid relative path");
      Assert_Equals (T, "../util",
                     Get_Relative_Path ("/home/john/src/asf/", "/home/john/src/util"),
                     "Invalid relative path");
      Assert_Equals (T, "../util/b",
                     Get_Relative_Path ("/home/john/src/asf", "/home/john/src/util/b"),
                     "Invalid relative path");
      Assert_Equals (T, "../as",
                     Get_Relative_Path ("/home/john/src/asf", "/home/john/src/as"),
                     "Invalid relative path");
      Assert_Equals (T, "../../",
                     Get_Relative_Path ("/home/john/src/asf", "/home/john"),
                     "Invalid relative path");
      Assert_Equals (T, "/usr/share/admin",
                     Get_Relative_Path ("/home/john/src/asf", "/usr/share/admin"),
                     "Invalid absolute path");
      Assert_Equals (T, "/home/john",
                     Get_Relative_Path ("home/john/src/asf", "/home/john"),
                     "Invalid relative path");
      Assert_Equals (T, "e",
                     Get_Relative_Path ("/home/john/src/asf", "/home/john/src/asf/e"),
                     "Invalid relative path");
      Assert_Equals (T, ".",
                     Get_Relative_Path ("/home/john/src/asf", "/home/john/src/asf/"),
                     "Invalid relative path");
   end Test_Get_Relative_Path;

end Util.Files.Tests;

Add test to check iterating over the search paths in reverse order


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

with Ada.Unchecked_Deallocation;
package body Util.Concurrent.Fifos is

   --  ------------------------------
   --  Put the element in the queue.
   --  ------------------------------
   procedure Enqueue (Into    : in out Fifo;
                      Item    : in Element_Type;
                      Wait    : in Duration := FOREVER) is
   begin
      if Wait < 0.0 then
         Into.Buffer.Enqueue (Item);
      else
         select
            Into.Buffer.Enqueue (Item);
         or
            delay Wait;
            raise Timeout;
         end select;
      end if;
   end Enqueue;

   --  ------------------------------
   --  Get an element from the queue.
   --  Wait until one element gets available.
   --  ------------------------------
   procedure Dequeue (From    : in out Fifo;
                      Item    : out Element_Type;
                      Wait    : in Duration := FOREVER) is
   begin
      if Wait < 0.0 then
         From.Buffer.Dequeue (Item);
      else
         select
            From.Buffer.Dequeue (Item);
         or
            delay Wait;
            raise Timeout;
         end select;
      end if;
   end Dequeue;

   --  ------------------------------
   --  Get the number of elements in the queue.
   --  ------------------------------
   function Get_Count (From : in Fifo) return Natural is
   begin
      return From.Buffer.Get_Count;
   end Get_Count;

   --  ------------------------------
   --  Set the queue size.
   --  ------------------------------
   procedure Set_Size (Into : in out Fifo;
                       Capacity : in Positive) is
   begin
      Into.Buffer.Set_Size (Capacity);
   end Set_Size;

   --  ------------------------------
   --  Initializes the queue.
   --  ------------------------------
   overriding
   procedure Initialize (Object : in out Fifo) is
   begin
      Object.Buffer.Set_Size (Default_Size);
   end Initialize;

   --  ------------------------------
   --  Release the queue elements.
   --  ------------------------------
   overriding
   procedure Finalize (Object : in out Fifo) is
   begin
      if Clear_On_Dequeue then
         while Object.Get_Count > 0 loop
            declare
               Unused : Element_Type;
            begin
               Object.Dequeue (Unused);
            end;
         end loop;
      end if;
      Object.Buffer.Set_Size (0);
   end Finalize;

   --  Queue of objects.
   protected body Protected_Fifo is

      --  ------------------------------
      --  Put the element in the queue.
      --  If the queue is full, wait until some room is available.
      --  ------------------------------
      entry Enqueue (Item : in Element_Type) when Count < Elements'Length is
      begin
         Elements (Last) := Item;
         Last := Last + 1;
         if Last > Elements'Last then
            Last := Elements'First;
         end if;
         Count := Count + 1;
      end Enqueue;

      --  ------------------------------
      --  Get an element from the queue.
      --  Wait until one element gets available.
      --  ------------------------------
      entry Dequeue (Item : out Element_Type) when Count > 0 is
      begin
         Count := Count - 1;
         Item := Elements (First);

         --  For the clear on dequeue mode, erase the queue element.
         --  If the element holds some storage or a reference, this gets cleared here.
         --  The element used to clear is at index 0 (which does not exist if Clear_On_Dequeue
         --  is false).  There is no overhead when this is not used
         --  (ie, instantiation/compile time flag).
         if Clear_On_Dequeue then
            Elements (First) := Elements (0);
         end if;
         First := First + 1;
         if First > Elements'Last then
            First := Elements'First;
         end if;
      end Dequeue;

      --  ------------------------------
      --  Get the number of elements in the queue.
      --  ------------------------------
      function Get_Count return Natural is
      begin
         return Count;
      end Get_Count;

      --  ------------------------------
      --  Set the queue size.
      --  ------------------------------
      procedure Set_Size (Capacity : in Natural) is
         procedure Free is new Ada.Unchecked_Deallocation (Element_Array, Element_Array_Access);
         First_Pos : Natural := 1;
      begin
         if Clear_On_Dequeue then
            First_Pos := 0;
         end if;
         if Capacity = 0 then
            Free (Elements);
         elsif Elements = null then
            Elements := new Element_Array (First_Pos .. Capacity);
         else
            declare
               New_Array : Element_Array_Access := new Element_Array (First_Pos .. Capacity);
            begin
               if Capacity > Elements'Length then
                  New_Array (First_Pos .. Elements'Last) := Elements (First_Pos .. Elements'Last);
               else
                  New_Array (First_Pos .. Capacity) := Elements (First_Pos .. Capacity);
               end if;

               Free (Elements);
               Elements := New_Array;
            end;
         end if;
      end Set_Size;

   end Protected_Fifo;

end Util.Concurrent.Fifos;

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

with Ada.Unchecked_Deallocation;
package body Util.Concurrent.Fifos is

   --  ------------------------------
   --  Put the element in the queue.
   --  ------------------------------
   procedure Enqueue (Into    : in out Fifo;
                      Item    : in Element_Type;
                      Wait    : in Duration := FOREVER) is
   begin
      if Wait < 0.0 then
         Into.Buffer.Enqueue (Item);
      else
         select
            Into.Buffer.Enqueue (Item);
         or
            delay Wait;
            raise Timeout;
         end select;
      end if;
   end Enqueue;

   --  ------------------------------
   --  Get an element from the queue.
   --  Wait until one element gets available.
   --  ------------------------------
   procedure Dequeue (From    : in out Fifo;
                      Item    : out Element_Type;
                      Wait    : in Duration := FOREVER) is
   begin
      if Wait < 0.0 then
         From.Buffer.Dequeue (Item);
      else
         select
            From.Buffer.Dequeue (Item);
         or
            delay Wait;
            raise Timeout;
         end select;
      end if;
   end Dequeue;

   --  ------------------------------
   --  Get the number of elements in the queue.
   --  ------------------------------
   function Get_Count (From : in Fifo) return Natural is
   begin
      return From.Buffer.Get_Count;
   end Get_Count;

   --  ------------------------------
   --  Set the queue size.
   --  ------------------------------
   procedure Set_Size (Into : in out Fifo;
                       Capacity : in Positive) is
   begin
      Into.Buffer.Set_Size (Capacity);
   end Set_Size;

   --  ------------------------------
   --  Initializes the queue.
   --  ------------------------------
   overriding
   procedure Initialize (Object : in out Fifo) is
   begin
      Object.Buffer.Set_Size (Default_Size);
   end Initialize;

   --  ------------------------------
   --  Release the queue elements.
   --  ------------------------------
   overriding
   procedure Finalize (Object : in out Fifo) is
   begin
      if Clear_On_Dequeue then
         while Object.Get_Count > 0 loop
            declare
               Unused : Element_Type;
            begin
               Object.Dequeue (Unused);
            end;
         end loop;
      end if;
      Object.Buffer.Set_Size (0);
   end Finalize;

   --  Queue of objects.
   protected body Protected_Fifo is

      --  ------------------------------
      --  Put the element in the queue.
      --  If the queue is full, wait until some room is available.
      --  ------------------------------
      entry Enqueue (Item : in Element_Type) when Count < Elements'Length is
      begin
         Elements (Last) := Item;
         Last := Last + 1;
         if Last > Elements'Last then
            if Clear_On_Dequeue then
               Last := Elements'First + 1;
            else
               Last := Elements'First;
            end if;
         end if;
         Count := Count + 1;
      end Enqueue;

      --  ------------------------------
      --  Get an element from the queue.
      --  Wait until one element gets available.
      --  ------------------------------
      entry Dequeue (Item : out Element_Type) when Count > 0 is
      begin
         Count := Count - 1;
         Item := Elements (First);

         --  For the clear on dequeue mode, erase the queue element.
         --  If the element holds some storage or a reference, this gets cleared here.
         --  The element used to clear is at index 0 (which does not exist if Clear_On_Dequeue
         --  is false).  There is no overhead when this is not used
         --  (ie, instantiation/compile time flag).
         if Clear_On_Dequeue then
            Elements (First) := Elements (0);
         end if;
         First := First + 1;
         if First > Elements'Last then
            First := Elements'First;
         end if;
      end Dequeue;

      --  ------------------------------
      --  Get the number of elements in the queue.
      --  ------------------------------
      function Get_Count return Natural is
      begin
         return Count;
      end Get_Count;

      --  ------------------------------
      --  Set the queue size.
      --  ------------------------------
      procedure Set_Size (Capacity : in Natural) is
         procedure Free is new Ada.Unchecked_Deallocation (Element_Array, Element_Array_Access);
         First_Pos : Natural := 1;
      begin
         if Clear_On_Dequeue then
            First_Pos := 0;
         end if;
         if Capacity = 0 then
            Free (Elements);
         elsif Elements = null then
            Elements := new Element_Array (First_Pos .. Capacity);
         else
            declare
               New_Array : Element_Array_Access := new Element_Array (First_Pos .. Capacity);
            begin
               if Capacity > Elements'Length then
                  New_Array (First_Pos .. Elements'Last) := Elements (First_Pos .. Elements'Last);
               else
                  New_Array (First_Pos .. Capacity) := Elements (First_Pos .. Capacity);
               end if;

               Free (Elements);
               Elements := New_Array;
            end;
         end if;
      end Set_Size;

   end Protected_Fifo;

end Util.Concurrent.Fifos;

Fix queue wrapping in the Clear_On_Dequeue instantiation mode


-----------------------------------------------------------------------
--  components-widgets-likes -- Social Likes Components
--  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.Locales;
with Util.Beans.Objects;
with Util.Strings.Tokenizers;

with ASF.Requests;
with ASF.Contexts.Writer;
package body ASF.Components.Widgets.Likes is

   FB_LAYOUT_ATTR      : aliased constant String := "data-layout";
   FB_SHOW_FACES_ATTR  : aliased constant String := "data-show-faces";
   FB_WIDTH_ATTR       : aliased constant String := "data-width";
   FB_ACTION_ATTR      : aliased constant String := "data-action";
   FB_FONT_ATTR        : aliased constant String := "data-font";
   FB_COlORSCHEME_ATTR : aliased constant String := "data-colorscheme";
   FB_REF_ATTR         : aliased constant String := "data-ref";
   FB_KIDS_ATTR        : aliased constant String := "data-kid_directed_site";

   FACEBOOK_ATTRIBUTE_NAMES : Util.Strings.String_Set.Set;
   FACEBOOK_SCRIPT_ATTRIBUTE : constant String := "asf.widgets.facebook.script";

   type Like_Generator_Binding is record
      Name      : Util.Strings.Name_Access;
      Generator : Like_Generator_Access;
   end record;

   type Like_Generator_Array is array (1 .. MAX_LIKE_GENERATOR) of Like_Generator_Binding;

   FB_NAME      : aliased constant String := "facebook";
   FB_GENERATOR : aliased Facebook_Like_Generator;

   Generators : Like_Generator_Array := (1 => (FB_NAME'Access, FB_GENERATOR'Access),
                                         others => (null, null));

   --  ------------------------------
   --  Render the facebook like button according to the component attributes.
   --  ------------------------------
   overriding
   procedure Render_Like (Generator : in Facebook_Like_Generator;
                          UI        : in UILike'Class;
                          Href      : in String;
                          Context   : in out ASF.Contexts.Faces.Faces_Context'Class) is
      Writer  : constant Contexts.Writer.Response_Writer_Access := Context.Get_Response_Writer;
      Request : constant ASF.Requests.Request_Access := Context.Get_Request;
   begin
      if not Context.Is_Ajax_Request and then
        Util.Beans.Objects.Is_Null (Request.Get_Attribute (FACEBOOK_SCRIPT_ATTRIBUTE)) then

         Request.Set_Attribute (FACEBOOK_SCRIPT_ATTRIBUTE, Util.Beans.Objects.To_Object (True));
         Writer.Queue_Script ("(function(d, s, id) { var js, fjs = d.getElementsByTagName(s)[0];"
                              & "if (d.getElementById(id)) return;"
                              & "js = d.createElement(s); js.id = id;"
                              & "js.src = ""//connect.facebook.net/");
         Writer.Queue_Script (Util.Locales.To_String (Context.Get_Locale));
         Writer.Queue_Script ("/all.js#xfbml=1&;appId=116337738505130");
         Writer.Queue_Script (Generator.App_Id);
         Writer.Queue_Script (""";fjs.parentNode.insertBefore(js, fjs);"
                              & "}(document, 'script', 'facebook-jssdk'));");
         Writer.Start_Element ("div");
         Writer.Write_Attribute ("id", "fb-root");
         Writer.End_Element ("div");
      end if;
      Writer.Start_Element ("div");
      Writer.Write_Attribute ("class", "fb-like");
      Writer.Write_Attribute ("data-href", Href);
      Writer.Write_Attribute ("data-send", "true");
      UI.Render_Attributes (Context, FACEBOOK_ATTRIBUTE_NAMES, Writer);
      Writer.End_Element ("div");
   end Render_Like;

   --  ------------------------------
   --  Get the link to submit in the like action.
   --  ------------------------------
   function Get_Link (UI      : in UILike;
                      Context : in ASF.Contexts.Faces.Faces_Context'Class) return String is
      Href : constant String := UI.Get_Attribute ("href", Context, "");
   begin
      if Href'Length > 0 then
         return Href;
      else
         return Context.Get_Request.Get_Request_URI;
      end if;
   end Get_Link;

   --  ------------------------------
   --  Render an image with the source link created from an email address to the Gravatars service.
   --  ------------------------------
   overriding
   procedure Encode_Begin (UI      : in UILike;
                           Context : in out ASF.Contexts.Faces.Faces_Context'Class) is

   begin
      if UI.Is_Rendered (Context) then
         declare
            Kind : constant String := UI.Get_Attribute ("type", Context, "");
            Href : constant String := UILike'Class (UI).Get_Link (Context);

            procedure Render (Name : in String; Done : out Boolean);

            procedure Render (Name : in String;
                              Done : out Boolean) is
               use type Util.Strings.Name_Access;
            begin
               Done := False;
               for I in Generators'Range loop
                  exit when Generators (I).Name = null;
                  if Generators (I).Name.all = Name then
                     Generators (I).Generator.Render_Like (UI, Href, Context);
                     return;
                  end if;
               end loop;
               UI.Log_Error ("Like type {0} is not recognized", Name);
            end Render;

         begin
            if Kind'Length = 0 then
               UI.Log_Error ("The like type is empty.");
            else
               Util.Strings.Tokenizers.Iterate_Tokens (Content => Kind, Pattern => ",",
                                                       Process => Render'Access);
            end if;
         end;
      end if;
   end Encode_Begin;

   --  ------------------------------
   --  Register the like generator under the given name.
   --  ------------------------------
   procedure Register_Like (Name      : in Util.Strings.Name_Access;
                            Generator : in Like_Generator_Access) is
      use type Util.Strings.Name_Access;
   begin
      for I in Generators'Range loop
         if Generators (I).Name = null then
            Generators (I).Name := Name;
            Generators (I).Generator := Generator;
            return;
         end if;
      end loop;
   end Register_Like;

begin
   FACEBOOK_ATTRIBUTE_NAMES.Insert (FB_LAYOUT_ATTR'Access);
   FACEBOOK_ATTRIBUTE_NAMES.Insert (FB_SHOW_FACES_ATTR'Access);
   FACEBOOK_ATTRIBUTE_NAMES.Insert (FB_WIDTH_ATTR'Access);
   FACEBOOK_ATTRIBUTE_NAMES.Insert (FB_ACTION_ATTR'Access);
   FACEBOOK_ATTRIBUTE_NAMES.Insert (FB_FONT_ATTR'Access);
   FACEBOOK_ATTRIBUTE_NAMES.Insert (FB_COlORSCHEME_ATTR'Access);
   FACEBOOK_ATTRIBUTE_NAMES.Insert (FB_REF_ATTR'Access);
   FACEBOOK_ATTRIBUTE_NAMES.Insert (FB_KIDS_ATTR'Access);
end ASF.Components.Widgets.Likes;

Implement the <w:like> button with Facebook like support


Add the ASIS file $i

Add the ASIS file $i


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

with Ada.Containers.Hashed_Maps;
with Ada.Containers.Vectors;
with Ada.Unchecked_Deallocation;
with Ada.Strings.Unbounded;

with Util.Refs;
with Util.Beans.Objects;
with Util.Beans.Objects.Vectors;
with Util.Serialize.IO.XML;
with Util.Serialize.Mappers;
with Util.Serialize.Mappers.Record_Mapper;

with GNAT.Regexp;
with Security.Controllers;

package body Security.Policies.Urls is

   --  ------------------------------
   --  URL policy
   --  ------------------------------

   --  Get the policy name.
   overriding
   function Get_Name (From : in URL_Policy) return String is
   begin
      return NAME;
   end Get_Name;

   --  Returns True if the user has the permission to access the given URI permission.
   function Has_Permission (Manager    : in URL_Policy;
                            Context    : in Security_Context_Access;
                            Permission : in URI_Permission'Class) return Boolean is
      Name  : constant String_Ref := To_String_Ref (Permission.URI);
      Ref   : constant Rules_Ref.Ref := Manager.Cache.Get;
      Rules : constant Rules_Access := Ref.Value;
      Pos   : constant Rules_Maps.Cursor := Rules.Map.Find (Name);
      Rule  : Access_Rule_Ref;
   begin
      --  If the rule is not in the cache, search for the access rule that
      --  matches our URI.  Update the cache.  This cache update is thread-safe
      --  as the cache map is never modified: a new cache map is installed.
      if not Rules_Maps.Has_Element (Pos) then
         declare
            New_Ref : constant Rules_Ref.Ref := Rules_Ref.Create;
         begin
            Rule := Manager.Find_Access_Rule (Permission.URI);
            New_Ref.Value.all.Map := Rules.Map;
            New_Ref.Value.all.Map.Insert (Name, Rule);
            Manager.Cache.Set (New_Ref);
         end;
      else
         Rule := Rules_Maps.Element (Pos);
      end if;

      --  Check if the user has one of the required permission.
      declare
         P       : constant Access_Rule_Access := Rule.Value;
         Granted : Boolean;
      begin
         if P /= null then
            for I in P.Permissions'Range loop
--                 Context.Has_Permission (P.Permissions (I), Granted);
               if Granted then
                  return True;
               end if;
            end loop;
         end if;
      end;
      return False;
   end Has_Permission;

   --  Grant the permission to access to the given URI to users having the To
   --  permissions.
   procedure Grant_URI_Permission (Manager : in out URL_Policy;
                                   URI     : in String;
                                   To      : in String) is
   begin
      null;
   end Grant_URI_Permission;

   --  ------------------------------
   --  Policy Configuration
   --  ------------------------------
   type Policy_Config is record
      Id          : Natural := 0;
      Permissions : Util.Beans.Objects.Vectors.Vector;
      Patterns    : Util.Beans.Objects.Vectors.Vector;
      Manager     : URL_Policy_Access;
   end record;
   type Policy_Config_Access is access all Policy_Config;

   --  Setup the XML parser to read the policy description.  For example:

   --  Find the access rule of the policy that matches the given URI.
   --  Returns the No_Rule value (disable access) if no rule is found.
   function Find_Access_Rule (Manager : in URL_Policy;
                              URI     : in String) return Access_Rule_Ref is

      Matched : Boolean := False;
      Result  : Access_Rule_Ref;

      procedure Match (P : in Policy);

      procedure Match (P : in Policy) is
      begin
         if GNAT.Regexp.Match (URI, P.Pattern) then
            Matched := True;
            Result  := P.Rule;
         end if;
      end Match;

      Last : constant Natural := Manager.Policies.Last_Index;
   begin
      for I in 1 .. Last loop
         Manager.Policies.Query_Element (I, Match'Access);
         if Matched then
            return Result;
         end if;
      end loop;
      return Result;
   end Find_Access_Rule;

   --  ------------------------------
   --  Initialize the permission manager.
   --  ------------------------------
   overriding
   procedure Initialize (Manager : in out URL_Policy) is
   begin
      Manager.Cache := new Rules_Ref.Atomic_Ref;
      Manager.Cache.Set (Rules_Ref.Create);
   end Initialize;

   --  ------------------------------
   --  Finalize the permission manager.
   --  ------------------------------
   overriding
   procedure Finalize (Manager : in out URL_Policy) is
      use Ada.Strings.Unbounded;
      use Security.Controllers;

      procedure Free is
        new Ada.Unchecked_Deallocation (Rules_Ref.Atomic_Ref,
                                        Rules_Ref_Access);
      procedure Free is
        new Ada.Unchecked_Deallocation (Security.Controllers.Controller'Class,
                                        Security.Controllers.Controller_Access);
      procedure Free is
        new Ada.Unchecked_Deallocation (Controller_Access_Array,
                                        Controller_Access_Array_Access);

   begin
      Free (Manager.Cache);
--        for I in Manager.Names'Range loop
--           exit when Manager.Names (I) = null;
--           Ada.Strings.Unbounded.Free (Manager.Names (I));
--        end loop;

   end Finalize;

   type Policy_Fields is (FIELD_ID, FIELD_PERMISSION, FIELD_URL_PATTERN, FIELD_POLICY);

   procedure Set_Member (P     : in out Policy_Config;
                         Field : in Policy_Fields;
                         Value : in Util.Beans.Objects.Object);

   procedure Process (Policy : in Policy_Config);

   procedure Set_Member (P     : in out Policy_Config;
                         Field : in Policy_Fields;
                         Value : in Util.Beans.Objects.Object) is
   begin
      case Field is
         when FIELD_ID =>
            P.Id := Util.Beans.Objects.To_Integer (Value);

         when FIELD_PERMISSION =>
            P.Permissions.Append (Value);

         when FIELD_URL_PATTERN =>
            P.Patterns.Append (Value);

         when FIELD_POLICY =>
            Process (P);
            P.Id := 0;
            P.Permissions.Clear;
            P.Patterns.Clear;

      end case;
   end Set_Member;

   procedure Process (Policy : in Policy_Config) is
      Pol    : Security.Policies.URLs.Policy;
      Count  : constant Natural := Natural (Policy.Permissions.Length);
      Rule   : constant Access_Rule_Ref := Access_Rule_Refs.Create (new Access_Rule (Count));
      Iter   : Util.Beans.Objects.Vectors.Cursor := Policy.Permissions.First;
      Pos    : Positive := 1;
   begin
      Pol.Rule := Rule;

      --  Step 1: Initialize the list of permission index in Access_Rule from the permission names.
      while Util.Beans.Objects.Vectors.Has_Element (Iter) loop
         declare
            Perm : constant Util.Beans.Objects.Object := Util.Beans.Objects.Vectors.Element (Iter);
            Name : constant String := Util.Beans.Objects.To_String (Perm);
         begin
            Rule.Value.all.Permissions (Pos) := Permissions.Get_Permission_Index (Name);
            Pos := Pos + 1;

         exception
            when Invalid_Name =>
               raise Util.Serialize.Mappers.Field_Error with "Invalid permission: " & Name;
         end;
         Util.Beans.Objects.Vectors.Next (Iter);
      end loop;

      --  Step 2: Create one policy for each URL pattern
      Iter := Policy.Patterns.First;
      while Util.Beans.Objects.Vectors.Has_Element (Iter) loop
         declare
            Pattern : constant Util.Beans.Objects.Object
              := Util.Beans.Objects.Vectors.Element (Iter);
         begin
            Pol.Id   := Policy.Id;
            Pol.Pattern := GNAT.Regexp.Compile (Util.Beans.Objects.To_String (Pattern));
            Policy.Manager.Policies.Append (Pol);
         end;
         Util.Beans.Objects.Vectors.Next (Iter);
      end loop;
   end Process;

   package Policy_Mapper is
     new Util.Serialize.Mappers.Record_Mapper (Element_Type        => Policy_Config,
                                               Element_Type_Access => Policy_Config_Access,
                                               Fields              => Policy_Fields,
                                               Set_Member          => Set_Member);

   Policy_Mapping        : aliased Policy_Mapper.Mapper;

   --  Setup the XML parser to read the policy description.
   overriding
   procedure Set_Reader_Config (Policy : in out URL_Policy;
                                Reader : in out Util.Serialize.IO.XML.Parser) is

--        Policy_Mapping        : aliased Policy_Mapper.Mapper;
      Config : Policy_Config_Access := new Policy_Config;
   begin
      Reader.Add_Mapping ("policy-rules", Policy_Mapping'Access);
      Reader.Add_Mapping ("module", Policy_Mapping'Access);
      Config.Manager := Policy'Unchecked_Access;
      Policy_Mapper.Set_Context (Reader, Config);
   end Set_Reader_Config;

begin
   Policy_Mapping.Add_Mapping ("policy", FIELD_POLICY);
   Policy_Mapping.Add_Mapping ("policy/@id", FIELD_ID);
   Policy_Mapping.Add_Mapping ("policy/permission", FIELD_PERMISSION);
   Policy_Mapping.Add_Mapping ("policy/url-pattern", FIELD_URL_PATTERN);
end Security.Policies.Urls;

Implement the URL security policy from the old Security.Permissions package


-----------------------------------------------------------------------
--  util-http-headers-tests - Unit tests for Headers
--  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 Util.Test_Caller;
package body Util.Http.Headers.Tests is

   use Util.Tests;

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Util.Http.Headers.Get_Accepted",
                       Test_Get_Accepted'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test the Get_Accepted function.
   --  ------------------------------
   procedure Test_Get_Accepted (T : in out Test) is
      use type Mimes.Mime_Access;

      M : Mimes.Mime_Access;
   begin
      M := Get_Accepted ("image/gif", Mimes.Images);
      T.Assert (M /= null, "Null mime returned");
      T.Assert_Equals (M.all, Mimes.Gif, "Bad accept");

      M := Get_Accepted ("image/*", Mimes.Images);
      T.Assert (M /= null, "Null mime returned");
      T.Assert_Equals (M.all, Mimes.Jpg, "Bad accept");

      M := Get_Accepted ("image/* q=0.2, image/svg+xml", Mimes.Images);
      T.Assert (M /= null, "Null mime returned");
      T.Assert_Equals (M.all, Mimes.Svg, "Bad accept");

      M := Get_Accepted ("image/* q=0.2, image/svg+xml", Mimes.Api);
      T.Assert (M = null, "Should not match");
   end Test_Get_Accepted;

end Util.Http.Headers.Tests;

Add the new tests for Headers package

Add the new tests for Headers package


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

with AWA.Storages.Models;
package AWA.Storages.Stores is

   --  ------------------------------
   --  Store Service
   --  ------------------------------
   type Store is limited interface;
   type Store_Access is access all Store'Class;

   procedure Save (Storage : in Store;
                   Into    : in out AWA.Storages.Models.Storage_Ref'Class;
                   Path    : in String) is abstract;

   procedure Load (Storage : in Store;
                   From    : in AWA.Storages.Models.Storage_Ref'Class;
                   Into    : in String) is abstract;

end AWA.Storages.Stores;

Define the store interface to support several storage services (file, database, Amazon)


------------------------------------------------------------------------------
--                                                                          --
--                 ASIS-for-GNAT IMPLEMENTATION COMPONENTS                  --
--                                                                          --
--          A S I S . D A T A _ D E C O M P O S I T I O N . A U X           --
--                                                                          --
--                                 S p e c                                  --
--                                                                          --
--            Copyright (c) 1995-2005, 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).                                                --
--                                                                          --
------------------------------------------------------------------------------

--  This package contains auxiliary routines needed by queries from
--  Asis.Data_Decomposition.

with Snames;  use Snames;

private package Asis.Data_Decomposition.Aux is

   --  If the documentation of a function which works on ASIS Element does
   --  not contain an explicit list of appropriate Element Kinds, this means,
   --  that the functon does not check the kind of its actual, and a caller
   --  is responsible for proving the correct argument.

   function Subtype_Model_Kind (S : Element) return Type_Model_Kinds;
   --  Defines Type_Model_Kind for A_Subtype_Indication Element.
   --  The current approach is:
   --
   --  - if the model kind of the type mark of S is A_Complex_Dynamic_Model
   --    or Not_A_Type_Model the result is also A_Complex_Dynamic_Model or
   --    Not_A_Type_Model respectively, regardless of the constraint imposed
   --    by S (if any); ???

   --  - if S does not contain an explicit constraint, its model kind is the
   --    same as of its type mark;
   --
   --  - if S contains an explicit constraint, then:
   --    o  if the constraint is static, the result is A_Simple_Static_Model;
   --
   --    o  if the constraint is dynamic, but the only dynamic components
   --       in this constraint are discriminants from the enclosing record
   --       type definition, then the result is A_Simple_Dynamic_Model;
   --
   --    o  otherwise the result is A_Complex_Dynamic_Model;

   type Constraint_Model_Kinds is (
      Not_A_Constraint_Model,
      --  non-defined
      Static_Constraint,
      --  constraint is defined by static expressions
      Discriminated,
      --  all the dynamic expressions in the constrain are discriminants of
      --  the enclosing record type definition
      External);
      --  the constraint contains external dynamic expressions

   function Constraint_Model_Kind (C : Element) return Constraint_Model_Kinds;
   --  Supposing that C is either index or discriminant constraint element,
   --  this function checks the model kind of this constraint.

   function Record_Model_Kind (R : Element) return Type_Model_Kinds;
   --  Provided that R is of A_Record_Type_Definition kind, defines
   --  the type model kind for it.

   function Type_Definition_From_Subtype_Mark (S : Element) return Element;
   --  Taking an Element which is a subtype mark defining a given component,
   --  this query computes the type definition for the (base) type denoted
   --  by this type mark.

   function Discriminant_Part_From_Type_Definition
     (T : Element)
      return Element;
   --  Provided that T is A_Type_Definition Element, it returns its
   --  known_discriminant_part (Nil_Element if there is no
   --  known_discriminant_part). In case of a derived type,
   --  known_discriminant_part of the parent type is returned in case if
   --  the declaration of this derived type does not have its own
   --  known_discriminant_part

   function Is_Derived_From_Record (TD : Element) return Boolean;
   function Is_Derived_From_Array  (TD : Element) return Boolean;
   --  Check if TD is A_Derived_Type_Definition element defining a type which
   --  is (directly or undirectly) derived from a record/array type.

   function Root_Record_Definition (Type_Def : Element) return Element;
   function Root_Array_Definition  (Type_Def : Element) return Element;
   --  If Is_Derived_From_Record/Is_Derived_From_Array (Type_Def), then this
   --  function returns the definition of a record type/array from which this
   --  type is derived (directly or indirectly). Otherwise it returns its
   --  argument unchanged.

   function Component_Type_Definition (E : Element) return Element;
   --  Provided that E is of A_Component_Declaration (Record_Component
   --  case) or A_Subtype_Indication (Array_Component case) kind (the function
   --  does not check this, a caller is responsible for providing the right
   --  argument), this function returns the type definition for this component
   --  (it unwinds all the subtypings, but not derivations)

   function Subtype_Entity (E : Element) return Entity_Id;
   --  Given E as A_Subtype_Indication element, this function computes the
   --  Entity Id of the corresponding type or subtype (which may be an
   --  implicit type created by the compiler as well)

   function Linear_Index
     (Inds        : Dimension_Indexes;
      Ind_Lengths : Dimention_Length;
      Conv        : Convention_Id := Convention_Ada)
      return Asis.ASIS_Natural;

   function De_Linear_Index
     (Index       : Asis.ASIS_Natural;
      D           : ASIS_Natural;
      Ind_Lengths : Dimention_Length;
      Conv        : Convention_Id := Convention_Ada)
      return Dimension_Indexes;
   --  These two functions perform index linearizetion-delinearization
   --  for DDA queries working with array componnets and indexes
   --  D is the number of dimention of an array componnet, Ind_Lengths is a
   --  list of lengths for each dimention, both these parameters should come
   --  from the caller, they should be extracted from the corresponding array
   --  component. The length of Dimension_Indexes returned by De_Linear_Index
   --  is D.
   --
   --  ???  What about checks that indexes and length are in right ranges???
   --  ???  Or should it be done in the calling context???

   function Max_Len (Component : Array_Component) return Asis.ASIS_Natural;
   --  Computes linearized length of array componnet

   function Wrong_Indexes
     (Component : Array_Component;
      Indexes   : Dimension_Indexes)
      return Boolean;
   --  Supposing that Componnet is not-null, this function checks if Indexes
   --  are in the expected ranges for this component (this check starts from
   --  checking that the dimentions are the same). Returns True if Indexes
   --  are NOT the appropriate indexes for the component, because this
   --  function is supposed to use as a check to detect an inappropriate
   --  argument of a query

   function Build_Discrim_List_If_Data_Presented
     (Rec          : Entity_Id;
      Data         : Asis.Data_Decomposition.Portable_Data;
      Ignore_Discs : Boolean := False)
      return         Discrim_List;
   --  This is a wrapper function for A4G.DDA_Aux.Build_Discrim_List.
   --  In case is Data is not Nil_Portable_Data, it behaves as
   --  A4G.DDA_Aux.Build_Discrim_List, otherwise if Ignore_Discs is not set
   --  ON, it tries to get the discriminant data from the discriminant
   --  constraint or default discriminant values, otherwise it returns
   --  Null_Discrims,

end Asis.Data_Decomposition.Aux;

Add the ASIS file $i

Add the ASIS file $i


------------------------------------------------------------------------------
--                                                                          --
--                 ASIS-for-GNAT IMPLEMENTATION COMPONENTS                  --
--                                                                          --
--                          A 4 G . A _ O U T P U T                         --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--            Copyright (C) 1995-2011, 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;    use Ada.Exceptions;
with Ada.Strings.Fixed; use Ada.Strings.Fixed;

--  with Asis.Text;         use Asis.Text;
with Asis.Elements;     use Asis.Elements;

with A4G.A_Debug;       use A4G.A_Debug;
with A4G.A_Types;       use A4G.A_Types;
with A4G.Int_Knds;      use A4G.Int_Knds;
with A4G.Contt;         use A4G.Contt;
with A4G.Contt.UT;      use A4G.Contt.UT;
with A4G.Contt.TT;      use A4G.Contt.TT;
with A4G.A_Opt;         use A4G.A_Opt;
with A4G.Vcheck;        use A4G.Vcheck;

with Asis.Set_Get;      use  Asis.Set_Get;

with Atree;             use Atree;
with Namet;             use Namet;
with Output;            use Output;
with Sinfo;             use Sinfo;
with Sinput;            use Sinput;

package body A4G.A_Output is

   LT : String renames A4G.A_Types.ASIS_Line_Terminator;

   ---------
   -- Add --
   ---------
   procedure Add (Phrase : String) is
   begin
      if Debug_Buffer_Len = Max_Debug_Buffer_Len then
         return;
      end if;
      for I in Phrase'Range loop
         Debug_Buffer_Len := Debug_Buffer_Len + 1;
         Debug_Buffer (Debug_Buffer_Len) := Phrase (I);
         if Debug_Buffer_Len = Max_Debug_Buffer_Len then
            exit;
         end if;
      end loop;
   end Add;

   ------------------
   -- ASIS_Warning --
   ------------------

   procedure ASIS_Warning
     (Message : String;
      Error   : Asis.Errors.Error_Kinds := Not_An_Error)
   is
   begin
      case ASIS_Warning_Mode is
         when Suppress =>
            null;
         when Normal =>
            Set_Standard_Error;
            Write_Str ("ASIS warning: ");
            Write_Eol;
            Write_Str (Message);
            Write_Eol;
            Set_Standard_Output;
         when Treat_As_Error =>
            --  ??? Raise_ASIS_Failed should be revised to use like that
            Raise_ASIS_Failed (
               Argument  => Nil_Element,
               Diagnosis => Message,
               Stat      => Error);
      end case;
   end ASIS_Warning;

   --------------------------------------
   --  Debug_String (Compilation Unit) --
   --------------------------------------

   --  SHOULD BE REVISED USING Debug_Buffer!!!

   function Debug_String (CUnit : Compilation_Unit) return String is
      LT : String renames A4G.A_Types.ASIS_Line_Terminator;
      U  : Unit_Id;
      C  : Context_Id;
   begin
      U := Get_Unit_Id  (CUnit);
      C := Encl_Cont_Id (CUnit);

      if No (U) then
         return "This is a Nil Compilation Unit";
      else
         Reset_Context (C);
         return LT &
             "Unit Id: " & Unit_Id'Image (U) & LT
             &
             "   Unit name: " & Unit_Name (CUnit) & LT
             &
             "   Kind:      " & Asis.Unit_Kinds'Image (Kind (C, U)) & LT
             &
             "   Class:     " & Asis.Unit_Classes'Image (Class (C, U)) & LT
             &
             "   Origin:    " & Asis.Unit_Origins'Image (Origin (C, U)) & LT
             &
             "   Enclosing Context Id: " & Context_Id'Image (C) & LT
             &
             "   Is consistent: " & Boolean'Image (Is_Consistent (C, U)) & LT
             &
             "-------------------------------------------------";
      end if;

   end Debug_String;

   procedure  Debug_String
     (CUnit    : Compilation_Unit;
      No_Abort : Boolean := False)
   is
      LT : String renames A4G.A_Types.ASIS_Line_Terminator;
      U  : Unit_Id;
      C  : Context_Id;
   begin
      Debug_Buffer_Len := 0;
      U                := Get_Unit_Id  (CUnit);
      C                := Encl_Cont_Id (CUnit);

      if No (U) then
         Add ("This is a Nil Compilation Unit");
      else
         Reset_Context (C);
         Add (LT);
         Add ("Unit Id: " & Unit_Id'Image (U) & LT);
         Add ("   Unit name: " & Unit_Name (CUnit) & LT);
         Add ("   Kind:      " & Asis.Unit_Kinds'Image (Kind (C, U)) & LT);
         Add ("   Class:     " & Asis.Unit_Classes'Image (Class (C, U)) & LT);
         Add ("   Origin:    " & Asis.Unit_Origins'Image (Origin (C, U)) & LT);
         Add ("   Enclosing Context Id: " & Context_Id'Image (C) & LT);
         Add ("   Is consistent: " &
                  Boolean'Image (Is_Consistent (C, U)) & LT);
         Add ("-------------------------------------------------");
      end if;

   exception
      when Ex : others =>

         if No_Abort then
            Add (LT & "Can not complete the unit debug image because of" & LT);
            Add (Exception_Information (Ex));
         else
            raise;
         end if;

   end Debug_String;

   -----------------------------
   --  Debug_String (Context) --
   -----------------------------

   --  SHOULD BE REVISED USING Debug_Buffer!!!

   function Debug_String (Cont : Context) return String is
      LT : String renames A4G.A_Types.ASIS_Line_Terminator;
      C  : constant Context_Id := Get_Cont_Id (Cont);

      Debug_String_Prefix : constant String :=
         "Context Id: " & Context_Id'Image (C) & LT;
   begin
      if C = Non_Associated then
         return Debug_String_Prefix
            &  "   This Context has never been associated";

      elsif not Is_Associated (C) and then
            not Is_Opened (C)
      then
         return Debug_String_Prefix
            &  "   This Context is dissociated at the moment";
      elsif not Is_Opened (C) then
      --  here Is_Associated (C)
         return Debug_String_Prefix
            &  "   This Context has associations," & LT
            &  "   but it is closed at the moment";
      else  -- here Is_Associated (C) and Is_Opened (C)
         return Debug_String_Prefix
            &
            "   This Context is opened at the moment" & LT
            &
            "      All tree files:   "
            & Tree_Id'Image (Last_Tree (C) - First_Tree_Id + 1) & LT
            &
            "      All units:        "
            & Unit_Id'Image (Last_Unit - First_Unit_Id + 1) & LT
            &
            "      Existing specs :  "
            & Natural'Image (Lib_Unit_Decls (C)) & LT
            &
            "      Existing bodies:  "
            & Natural'Image (Comp_Unit_Bodies (C)) & LT
            &
            "      Nonexistent units:"
            & Natural'Image (Natural (Last_Unit - First_Unit_Id + 1) -
                (Lib_Unit_Decls (C) + Comp_Unit_Bodies (C)))
            & LT
            & "=================";
      end if;
   end Debug_String;

   -----------------------------
   --  Debug_String (Element) --
   -----------------------------

   procedure Debug_String
     (E        : Element;
      No_Abort : Boolean := False)
   is
      E_Kind       : constant Internal_Element_Kinds := Int_Kind (E);
      E_Kind_Image : constant String := Internal_Element_Kinds'Image (E_Kind);
      E_Unit       : constant Asis.Compilation_Unit := Encl_Unit (E);
      E_Unit_Class : constant Unit_Classes := Class (E_Unit);

      N     : constant Node_Id := Node         (E);
      R_N   : constant Node_Id := R_Node       (E);
      N_F_1 : constant Node_Id := Node_Field_1 (E);
      N_F_2 : constant Node_Id := Node_Field_2 (E);

      C  : constant Context_Id := Encl_Cont_Id (E);
      T  : constant Tree_Id    := Encl_Tree    (E);
   begin

      Debug_Buffer_Len := 0;

      if Is_Nil (E) then
         Add ("This is a Nil Element");
      else
         Add (E_Kind_Image);
         Add (LT & "located in ");
         Add (Unit_Name (E_Unit));

         if E_Unit_Class = A_Separate_Body then
            Add (" (subunit, Unit_Id =");
         elsif E_Unit_Class = A_Public_Declaration or else
               E_Unit_Class =  A_Private_Declaration
         then
            Add (" (spec, Unit_Id =");
         else
            Add (" (body, Unit_Id =");
         end if;

         Add (Unit_Id'Image (Encl_Unit_Id (E)));
         Add (", Context_Id =");
         Add (Context_Id'Image (C));
         Add (")" & LT);

         if not (Debug_Flag_I) then
            Add ("text position :");

--            if not Is_Text_Available (E) then

               --  Creating the source location from the element node. We
               --  cannot safely use Element_Span here because in case of a
               --  bug in a structural query this may result in curcling of
               --  query blow-ups.

               if Sloc (N) <= No_Location then
                  Add (" not available");
                  Add (LT);
               else

                  Add (" ");

                  declare
                     use Ada.Strings;

                     P              : Source_Ptr;
                     Sindex         : Source_File_Index;
                     Instance_Depth : Natural := 0;

                     procedure Enter_Sloc;
                     --  For the current value of P, adds to the debug string
                     --  the string of the form file_name:line_number. Also
                     --  computes Sindex as the Id of the sourse file of P.

                     procedure Enter_Sloc is
                        F_Name : File_Name_Type;
                     begin
                        Sindex := Get_Source_File_Index (P);
                        F_Name := File_Name (Sindex);

                        Get_Name_String (F_Name);

                        Add (Name_Buffer (1 .. Name_Len) & ":");
                        Add (Trim (Get_Physical_Line_Number (P)'Img, Both));
                        Add (":");
                        Add (Trim (Get_Column_Number (P)'Img, Both));
                     end Enter_Sloc;

                  begin

                     P := Sloc (N);
                     Enter_Sloc;
                     P := Instantiation (Sindex);

                     while P /= No_Location loop
                        Add ("[");
                        Instance_Depth := Instance_Depth + 1;
                        Enter_Sloc;
                        P := Instantiation (Sindex);

                     end loop;

                     for J in 1 .. Instance_Depth loop
                        Add ("]");
                     end loop;

                     Add (LT);
                  end;

               end if;

--            else
--               declare
--                  Arg_Span : Span;
--                  FL : String_Ptr;
--                  LL : String_Ptr;
--                  FC : String_Ptr;
--                  LC : String_Ptr;
--               begin
--                  --  this operation is potentially dangerous - it may
--                  --  change the tree (In fact, it should not, if we
--                  --  take into account the typical conditions when
--                  --  this routine is called
--                  Arg_Span := Element_Span (E);
--                  FL := new String'(Line_Number'Image (Arg_Span.First_Line));
--                  LL := new String'(Line_Number'Image (Arg_Span.Last_Line));
--                  FC := new String'(Character_Position'Image
--                              (Arg_Span.First_Column));
--                  LC := new String'(Character_Position'Image
--                              (Arg_Span.Last_Column));
--                  Add (FL.all);
--                  Add (" :");
--                  Add (FC.all);
--                  Add (" -");
--                  Add (LL.all);
--                  Add (" :");
--                  Add (LC.all);
--                  Add (LT);
--               end;
--            end if;

         end if;

         Add ("   Nodes:" & LT);
         Add ("      Node            :" & Node_Id'Image (N));
         Add (" - " & Node_Kind'Image (Nkind (N)) & LT);

         Add ("      R_Node          :" & Node_Id'Image (R_N));
         Add (" - " & Node_Kind'Image (Nkind (R_N)) & LT);

         Add ("      Node_Field_1    :" & Node_Id'Image (N_F_1));
         Add (" - " & Node_Kind'Image (Nkind (N_F_1)) & LT);

         Add ("      Node_Field_2    :" & Node_Id'Image (N_F_2));
         Add (" - " & Node_Kind'Image (Nkind (N_F_2)) & LT);

         Add ("   Rel_Sloc           :");
         Add (Source_Ptr'Image (Rel_Sloc (E)) & LT);

         if Special_Case (E) /= Not_A_Special_Case then
            Add ("   Special Case       : ");
            Add (Special_Cases'Image (Special_Case (E)) & LT);

         end if;

         if Special_Case (E) = Stand_Char_Literal or else
            Character_Code (E) /= 0
         then
            Add ("   Character_Code     :");
            Add (Char_Code'Image (Character_Code (E)) & LT);
         end if;

         case Normalization_Case (E) is
            when Is_Normalized =>
               Add ("   Normalized" & LT);
            when Is_Normalized_Defaulted =>
               Add ("   Normalized (with default value)" & LT);
            when Is_Normalized_Defaulted_For_Box =>
               Add ("   Normalized (with default value computed for box)"
                    & LT);
            when Is_Not_Normalized =>
               null;
         end case;

         if Parenth_Count (E) > 0 then
            Add ("   Parenth_Count      :");
            Add (Nat'Image (Parenth_Count (E)) & LT);
         end if;

         if Is_From_Implicit (E) then
            Add ("   Is implicit" & LT);
         end if;

         if Is_From_Inherited (E) then
            Add ("   Is inherited" & LT);
         end if;

         if Is_From_Instance (E) then
            Add ("   Is from instance" & LT);
         end if;

         Add ("   obtained from the tree ");

         if Present (T) then
            Get_Name_String (C, T);
            Add (A_Name_Buffer (1 ..  A_Name_Len));
            Add (" (Tree_Id =" & Tree_Id'Image (T) & ")");
         else
            Add (" <nil tree>");
         end if;

      end if;

   exception
      when Ex : others =>

         if No_Abort then
            Add (LT & "Can not complete the unit debug image because of" & LT);
            Add (Exception_Information (Ex));
         else
            raise;
         end if;

   end Debug_String;

   ----------------
   -- Write_Node --
   ----------------

   procedure Write_Node (N : Node_Id; Prefix : String := "") is
   begin
      Write_Str (Prefix);
      Write_Str ("Node_Id =  ");
      Write_Int (Int (N));
      Write_Eol;
      Write_Str (Prefix);
      Write_Str ("Nkind   =  ");
      Write_Str (Node_Kind'Image (Nkind (N)));
      Write_Eol;
      Write_Str (Prefix);
      Write_Str ("Rewrite_Sub       value : ");
      Write_Str (Boolean'Image (Is_Rewrite_Substitution (N)));
      Write_Eol;
      Write_Str (Prefix);
      Write_Str ("Rewrite_Ins       value : ");
      Write_Str (Boolean'Image (Is_Rewrite_Insertion (N)));
      Write_Eol;
      Write_Str (Prefix);
      Write_Str ("Comes_From_Source value : ");
      Write_Str (Boolean'Image (Comes_From_Source (N)));
      Write_Eol;

      if Original_Node (N) = N then
         Write_Str (Prefix);
         Write_Str ("  Node is unchanged");
         Write_Eol;
      elsif Original_Node (N) = Empty then
         Write_Str (Prefix);
         Write_Str ("  Node has been inserted");
         Write_Eol;
      else
         Write_Str (Prefix);
         Write_Str ("  Node has been rewritten");
         Write_Eol;
         Write_Node (N      => Original_Node (N),
                     Prefix => Write_Node.Prefix & " Original node -> ");
      end if;

      Write_Eol;

   end Write_Node;

end A4G.A_Output;

Add the ASIS file $i

Add the ASIS file $i


with Ada.Text_IO;

procedure HelloWorld is
begin
   Ada.Text_IO.Put_Line("Hello, world!");
end HelloWorld;

Create hello_world.adb

Create hello_world.adb


------------------------------------------------------------------------------
--                                                                          --
--                 ASIS-for-GNAT IMPLEMENTATION COMPONENTS                  --
--                                                                          --
--                          A 4 G . D E F A U L T S                         --
--                                                                          --
--                                 S p e c                                  --
--                                                                          --
--            Copyright (c) 1995-1999, 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,  59 Temple Place --
-- - Suite 330,  Boston, MA 02111-1307, 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  Ada Core Technologies Inc --
-- (http://www.gnat.com).                                                   --
--                                                                          --
------------------------------------------------------------------------------

--  This package defines the default directory source paths which are the same
--  for any ASIS context.
--
--  In many aspects this package loks like the corresponding part of the
--  GNAT Osint package (see, in particular the code of Osint.Initialize
--  and Osint routines for locating files. But we cannot use Osint directly.

with A4G.A_Types; use A4G.A_Types;

with GNAT.OS_Lib; use GNAT.OS_Lib;

with Table;

package A4G.Defaults is

   ----------------------------------------------
   -- Data Structures for Default Search Paths --
   ----------------------------------------------

   package ASIS_Src_Search_Directories is new Table.Table (
     Table_Component_Type => String_Access,
     Table_Index_Type     => Dir_Id,
     Table_Low_Bound      => First_Dir_Id,
     Table_Initial        => 12,
     Table_Increment      => 100,
     Table_Name           => "A4G.Defaults.Src_Search_Directories");
   --  Table of the names of the directories listed as the value of the
   --  ADA_INCLUDE_PATH environment variable

   package ASIS_Lib_Search_Directories is new Table.Table (
     Table_Component_Type => String_Access,
     Table_Index_Type     => Dir_Id,
     Table_Low_Bound      => First_Dir_Id,
     Table_Initial        => 12,
     Table_Increment      => 100,
     Table_Name           => "A4G.Defaults.Lib_Search_Directories");
   --  Table of the names of the directories listed as the value of the
   --  ADA_OBJECT_PATH environment variable. We are considering object
   --  and ALI files coming together, so we call them both as library
   --  files.

   package ASIS_Tree_Search_Directories is new Table.Table (
     Table_Component_Type => String_Access,
     Table_Index_Type     => Dir_Id,
     Table_Low_Bound      => First_Dir_Id,
     Table_Initial        => 12,
     Table_Increment      => 100,
     Table_Name           => "A4G.Defaults.Lib_Search_Directories");
   --  Table of the names of the directories for dfault trees. Currently
   --  contains exactly the same information as the table defined by
   --  ASIS_Lib_Search_Directories, because we consider, that
   --  the ADA_INCLUDE_PATH environment variable also defines the
   --  "default" location for tree files. This may be changed if we decide
   --  to use a separate environment variable for trees

   procedure Initialize;
   --  Initialises the tables containing the default search paths by
   --  examining the environment variables. This procedure should
   --  be called when ASIS is initialized, and ontly in this situation.

   procedure Finalize;
   --  reclames all the storage used by strings which store the default
   --  source paths.
   --  This procedure should be called when ASIS is finalized, and only
   --  in this situation.

   function Locate_Default_File
     (File_Name : String_Access;
      Dir_Kind  : Search_Dir_Kinds)
      return String_Access;
   --  Tries to locate the given file in the default directories, following
   --  the order in which these directories are listed in the values of
   --  the corresponding environment variables. Returns the full file name,
   --  if the fle has been located, or returns a null access value otherwise.

   procedure Print_Source_Defaults;
   procedure Print_Lib_Defaults;
   procedure Print_Tree_Defaults;
   --  these procedures produce the debug output for the tables storing the
   --  default source paths.
end A4G.Defaults;

Add the ASIS file $i

Add the ASIS file $i


------------------------------------------------------------------------------
--                                                                          --
--                 ASIS-for-GNAT IMPLEMENTATION COMPONENTS                  --
--                                                                          --
--                             A 4 G . A _ S E M                            --
--                                                                          --
--                                 S p e c                                  --
--                                                                          --
--            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,  59 Temple Place --
-- - Suite 330,  Boston, MA 02111-1307, 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  Ada Core Technologies Inc --
-- (http://www.gnat.com).                                                   --
--                                                                          --
------------------------------------------------------------------------------

--  This package is the root of the ASIS-for-GNAT implementation hierarchy.
--  All the implementation components, except Asis.Set_Get and
--  Asis.Text.Set_Get (which need access to the private parts of the
--  corresponding ASIS interface packages), are children or grandchildren of
--  A4G. (A4G stands for Asis For GNAT).
--
--  The primary aim of this package is to constrain the pollution of the user
--  namespace when using the ASIS library to create ASIS applications, by
--  children of A4G.

package A4G is
   pragma Pure (A4G);
end A4G;

Add the ASIS file $i

Add the ASIS file $i


-----------------------------------------------------------------------
--  util-beans-objects-readers -- Datasets
--  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.Serialize.IO;
package body Util.Beans.Objects.Readers is

   --  -----------------------
   --  Start a new object associated with the given name.  This is called when
   --  the '{' is reached.  The reader must be updated so that the next
   --  Set_Member procedure will associate the name/value pair on the
   --  new object.
   --  -----------------------
   overriding
   procedure Start_Object (Handler : in out Parser;
                           Name    : in String) is
   begin
      if Name'Length > 0 then
         Ada.Strings.Unbounded.Append (Handler.Base_Name, Name);
         Ada.Strings.Unbounded.Append (Handler.Base_Name, Handler.Separator);
         Length_Stack.Push (Handler.Lengths);
         Length_Stack.Current (Handler.Lengths).all := Name'Length + Handler.Separator_Length;
      end if;
   end Start_Object;

   --  -----------------------
   --  Finish an object associated with the given name.  The reader must be
   --  updated to be associated with the previous object.
   --  -----------------------
   overriding
   procedure Finish_Object (Handler : in out Parser;
                            Name    : in String) is
      Len : constant Natural := Ada.Strings.Unbounded.Length (Handler.Base_Name);
   begin
      if Name'Length > 0 then
         Ada.Strings.Unbounded.Delete (Handler.Base_Name,
                                       Len - Name'Length - Handler.Separator_Length + 1, Len);
      end if;
   end Finish_Object;

   overriding
   procedure Start_Array (Handler : in out Parser;
                          Name    : in String) is
   begin
      Handler.Start_Object (Name);
--      Util.Serialize.IO.JSON.Parser (Handler).Start_Array (Name);
   end Start_Array;

   overriding
   procedure Finish_Array (Handler : in out Parser;
                           Name    : in String;
                           Count   : in Natural) is
   begin
      Parser'Class (Handler).Set_Member ("length", Util.Beans.Objects.To_Object (Count));
      Handler.Finish_Object (Name);
   end Finish_Array;

   --  -----------------------
   --  Set the name/value pair on the current object.  For each active mapping,
   --  find whether a rule matches our name and execute it.
   --  -----------------------
   overriding
   procedure Set_Member (Handler   : in out Reader;
                         Name      : in String;
                         Value     : in Util.Beans.Objects.Object;
                         Attribute : in Boolean := False) is
      pragma Unreferenced (Attribute);
   begin
      Handler.Current.Set_Value (Name, Value);
   end Set_Member;

   --  Report an error while parsing the input stream.  The error message will be reported
   --  on the logger associated with the parser.  The parser will be set as in error so that
   --  the Has_Error function will return True after parsing the whole file.
   procedure Error (Handler : in out Parser;
                    Message : in String) is
   begin
      null;
   end Error;

end Util.Beans.Objects.Readers;

Implement operations for the object reader type