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

   type Target_Memory is limited record
      Reader        : MAT.Readers.Reader_Access;
      Memory_Slots  : Allocation_Map;
      Frames        : MAT.Frames.Frame_Type;
--        Event_Channel : MAT.Memory.Events.Memory_Event_Channel.Channel;
   end record;
   type Client_Memory_Ref is access all Target_Memory;

   --  Initialize the target memory object to manage the memory slots, the stack frames
   --  and setup the reader to analyze the memory events.
   procedure Initialize (Memory : in out Target_Memory;
                         Reader : in out MAT.Readers.Manager_Base'Class);

   type Size_Info_Type is record
      Count : Natural;
   end record;

   use type MAT.Types.Target_Size;

   package Size_Info_Maps is
     new Ada.Containers.Ordered_Maps (Key_Type => MAT.Types.Target_Size,
                                      Element_Type => Size_Info_Type);
   subtype Size_Info_Map is Size_Info_Maps.Map;
   subtype Size_Info_Cursor is Size_Info_Maps.Cursor;

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

private

   protected type Memory_Allocator is

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

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

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

   private
      Used_Slots    : Allocation_Map;
      Freed_Slots   : Allocation_Map;
      Frames        : MAT.Frames.Frame_Type;
   end Memory_Allocator;

end MAT.Memory.Targets;

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

   type Target_Memory is limited private;
   type Client_Memory_Ref is access all Target_Memory;

   --  Initialize the target memory object to manage the memory slots, the stack frames
   --  and setup the reader to analyze the memory events.
   procedure Initialize (Memory : in out Target_Memory;
                         Reader : in out MAT.Readers.Manager_Base'Class);

   type Size_Info_Type is record
      Count : Natural;
   end record;

   use type MAT.Types.Target_Size;

   package Size_Info_Maps is
     new Ada.Containers.Ordered_Maps (Key_Type => MAT.Types.Target_Size,
                                      Element_Type => Size_Info_Type);
   subtype Size_Info_Map is Size_Info_Maps.Map;
   subtype Size_Info_Cursor is Size_Info_Maps.Cursor;

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

private

   protected type Memory_Allocator is

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

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

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

   private
      Used_Slots    : Allocation_Map;
      Freed_Slots   : Allocation_Map;
      Frames        : MAT.Frames.Frame_Type;
   end Memory_Allocator;

   type Target_Memory is limited record
      Reader        : MAT.Readers.Reader_Access;
      Memory        : Memory_Allocator;
   end record;

end MAT.Memory.Targets;

Change Target_Memory to a private type

Change Target_Memory to a private type


-----------------------------------------------------------------------
--  security-policies-urls -- URL security policy
--  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.Unchecked_Deallocation;

with Util.Beans.Objects;
with Util.Beans.Objects.Vectors;
with Util.Serialize.Mappers;
with Util.Serialize.Mappers.Record_Mapper;

with Security.Contexts;

package body Security.Policies.Urls is

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

   --  ------------------------------
   --  Get the policy name.
   --  ------------------------------
   overriding
   function Get_Name (From : in URL_Policy) return String is
      pragma Unreferenced (From);
   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

      procedure Free is
        new Ada.Unchecked_Deallocation (Rules_Ref.Atomic_Ref,
                                        Rules_Ref_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 URL_Policy'Class;
                         Field : in Policy_Fields;
                         Value : in Util.Beans.Objects.Object);

   procedure Process (Policy : in out URL_Policy'Class);

   procedure Set_Member (P     : in out URL_Policy'Class;
                         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 out URL_Policy'Class) 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.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        => URL_Policy'Class,
                                               Element_Type_Access => URL_Policy_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 Prepare_Config (Policy : in out URL_Policy;
                             Reader : in out Util.Serialize.IO.XML.Parser) is
   begin
      Reader.Add_Mapping ("policy-rules", Policy_Mapping'Access);
      Reader.Add_Mapping ("module", Policy_Mapping'Access);
      Policy_Mapper.Set_Context (Reader, Policy'Unchecked_Access);
   end Prepare_Config;

   --  ------------------------------
   --  Get the URL policy associated with the given policy manager.
   --  Returns the URL policy instance or null if it was not registered in the policy manager.
   --  ------------------------------
   function Get_URL_Policy (Manager : in Security.Policies.Policy_Manager'Class)
                            return URL_Policy_Access is
      Policy : constant Security.Policies.Policy_Access := Manager.Get_Policy (NAME);
   begin
      if Policy = null or else not (Policy.all in URL_Policy'Class) then
         return null;
      else
         return URL_Policy'Class (Policy.all)'Access;
      end if;
   end Get_URL_Policy;

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

-----------------------------------------------------------------------
--  security-policies-urls -- URL security policy
--  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.Unchecked_Deallocation;

with Util.Beans.Objects;
with Util.Beans.Objects.Vectors;
with Util.Serialize.Mappers;
with Util.Serialize.Mappers.Record_Mapper;

with Security.Contexts;

package body Security.Policies.URLs is

   --  ------------------------------
   --  Get the policy name.
   --  ------------------------------
   overriding
   function Get_Name (From : in URL_Policy) return String is
      pragma Unreferenced (From);
   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 URL_Permission'Class) return Boolean is
      Name  : constant String_Ref := To_String_Ref (Permission.URL);
      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.URL);
            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
   --  ------------------------------

   --  ------------------------------
   --  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

      procedure Free is
        new Ada.Unchecked_Deallocation (Rules_Ref.Atomic_Ref,
                                        Rules_Ref_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 URL_Policy'Class;
                         Field : in Policy_Fields;
                         Value : in Util.Beans.Objects.Object);

   procedure Process (Policy : in out URL_Policy'Class);

   procedure Set_Member (P     : in out URL_Policy'Class;
                         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 out URL_Policy'Class) 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.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        => URL_Policy'Class,
                                               Element_Type_Access => URL_Policy_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 Prepare_Config (Policy : in out URL_Policy;
                             Reader : in out Util.Serialize.IO.XML.Parser) is
   begin
      Reader.Add_Mapping ("policy-rules", Policy_Mapping'Access);
      Reader.Add_Mapping ("module", Policy_Mapping'Access);
      Policy_Mapper.Set_Context (Reader, Policy'Unchecked_Access);
   end Prepare_Config;

   --  ------------------------------
   --  Get the URL policy associated with the given policy manager.
   --  Returns the URL policy instance or null if it was not registered in the policy manager.
   --  ------------------------------
   function Get_URL_Policy (Manager : in Security.Policies.Policy_Manager'Class)
                            return URL_Policy_Access is
      Policy : constant Security.Policies.Policy_Access := Manager.Get_Policy (NAME);
   begin
      if Policy = null or else not (Policy.all in URL_Policy'Class) then
         return null;
      else
         return URL_Policy'Class (Policy.all)'Access;
      end if;
   end Get_URL_Policy;

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

Rename the package URLs

Rename the package URLs


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

with AWS.Headers.Set;
with AWS.Client;
with AWS.Messages;
package body Util.Http.Clients.Web is

   Manager : aliased AWS_Http_Manager;

   --  ------------------------------
   --  Register the Http manager.
   --  ------------------------------
   procedure Register is
   begin
      Default_Http_Manager := Manager'Access;
   end Register;

   function To_Status (Code : in AWS.Messages.Status_Code) return Natural;

   function To_Status (Code : in AWS.Messages.Status_Code) return Natural is
      use AWS.Messages;
   begin
      case Code is
         when S100 =>
            return 100;
         when S101 =>
            return 101;
         when S102 =>
            return 102;
         when S200 =>
            return 200;
         when S201 =>
            return 201;
         when S203 =>
            return 203;
         when S204 =>
            return 204;
         when S205 =>
            return 205;
         when S206 =>
            return 206;
         when S207 =>
            return 207;
         when S300 =>
            return 300;
         when S301 =>
            return 301;
         when S302 =>
            return 302;
         when S303 =>
            return 303;
         when S304 =>
            return 304;
         when S305 =>
            return 305;
         when S307 =>
            return 307;
         when S400 =>
            return 400;
         when S401 =>
            return 401;
         when S402 =>
            return 402;
         when S403 =>
            return 403;
         when S404 =>
            return 404;
         when S405 =>
            return 405;
         when S406 =>
            return 406;
         when S407 =>
            return 407;
         when S408 =>
            return 408;
         when S409 =>
            return 409;
         when S410 =>
            return 410;
         when S411 =>
            return 411;
         when S412 =>
            return 412;
         when S413 =>
            return 413;
         when S414 =>
            return 414;
         when S415 =>
            return 415;
         when S416 =>
            return 416;
         when S417 =>
            return 417;
         when S422 =>
            return 422;
         when S423 =>
            return 423;
         when S424 =>
            return 424;
         when S500 =>
            return 500;
         when S501 =>
            return 501;
         when S502 =>
            return 502;
         when S503 =>
            return 503;
         when S504 =>
            return 504;
         when S505 =>
            return 505;
         when S507 =>
            return 507;
         when others =>
            return 500;
      end case;
   end To_Status;

   procedure Create (Manager  : in AWS_Http_Manager;
                     Http     : in out Client'Class) is
      pragma Unreferenced (Manager);
   begin
      Http.Delegate := new AWS_Http_Request;
   end Create;

   procedure Do_Get (Manager  : in AWS_Http_Manager;
                     Http     : in Client'Class;
                     URI      : in String;
                     Reply    : out Response'Class) is
      pragma Unreferenced (Manager);

      Req     : constant AWS_Http_Request_Access
        := AWS_Http_Request'Class (Http.Delegate.all)'Access;
      Rep     : constant AWS_Http_Response_Access := new AWS_Http_Response;
   begin
      Reply.Delegate := Rep.all'Access;
      Rep.Data       := AWS.Client.Get (URL => URI, Headers => Req.Headers);
   end Do_Get;

   procedure Do_Post (Manager  : in AWS_Http_Manager;
                      Http     : in Client'Class;
                      URI      : in String;
                      Data     : in String;
                      Reply    : out Response'Class) is
      pragma Unreferenced (Manager);

      Req     : constant AWS_Http_Request_Access
        := AWS_Http_Request'Class (Http.Delegate.all)'Access;
      Rep     : constant AWS_Http_Response_Access := new AWS_Http_Response;
   begin
      Reply.Delegate := Rep.all'Access;
      Rep.Data       := AWS.Client.Post (URL => URI, Data => Data, Headers => Req.Headers);
   end Do_Post;

   --  ------------------------------
   --  Returns a boolean indicating whether the named request header has already
   --  been set.
   --  ------------------------------
   function Contains_Header (Http : in AWS_Http_Request;
                             Name : in String) return Boolean is
   begin
      raise Program_Error with "Contains_Header is not implemented";
      return False;
   end Contains_Header;

   --  Returns the value of the specified request header as a String. If the request
   --  did not include a header of the specified name, this method returns null.
   --  If there are multiple headers with the same name, this method returns the
   --  first head in the request. The header name is case insensitive. You can use
   --  this method with any response header.
   overriding
   function Get_Header (Request : in AWS_Http_Request;
                        Name    : in String) return String is
   begin
      return "";
   end Get_Header;

   --  ------------------------------
   --  Sets a request header with the given name and value. If the header had already
   --  been set, the new value overwrites the previous one. The containsHeader
   --  method can be used to test for the presence of a header before setting its value.
   --  ------------------------------
   overriding
   procedure Set_Header (Http  : in out AWS_Http_Request;
                         Name  : in String;
                         Value : in String) is
   begin
      AWS.Headers.Set.Add (Http.Headers, Name, Value);
   end Set_Header;

   --  ------------------------------
   --  Adds a request header with the given name and value.
   --  This method allows request headers to have multiple values.
   --  ------------------------------
   overriding
   procedure Add_Header (Http  : in out AWS_Http_Request;
                         Name  : in String;
                         Value : in String) is
   begin
      AWS.Headers.Set.Add (Http.Headers, Name, Value);
   end Add_Header;

   --  Iterate over the request headers and executes the Process procedure.
   overriding
   procedure Iterate_Headers (Request : in AWS_Http_Request;
                              Process : not null access
                                procedure (Name  : in String;
                                           Value : in String)) is
   begin
      null;
   end Iterate_Headers;

   --  ------------------------------
   --  Returns a boolean indicating whether the named response header has already
   --  been set.
   --  ------------------------------
   function Contains_Header (Reply : in AWS_Http_Response;
                             Name  : in String) return Boolean is
   begin
      return AWS.Response.Header (Reply.Data, Name) /= "";
   end Contains_Header;

   --  ------------------------------
   --  Returns the value of the specified response header as a String. If the response
   --  did not include a header of the specified name, this method returns null.
   --  If there are multiple headers with the same name, this method returns the
   --  first head in the request. The header name is case insensitive. You can use
   --  this method with any response header.
   --  ------------------------------
   function Get_Header (Reply  : in AWS_Http_Response;
                        Name   : in String) return String is
   begin
      return AWS.Response.Header (Reply.Data, Name);
   end Get_Header;

   --  Sets a message header with the given name and value. If the header had already
   --  been set, the new value overwrites the previous one. The containsHeader
   --  method can be used to test for the presence of a header before setting its value.
   overriding
   procedure Set_Header (Reply    : in out AWS_Http_Response;
                         Name     : in String;
                         Value    : in String) is
   begin
      null;
   end Set_Header;

   --  Adds a request header with the given name and value.
   --  This method allows request headers to have multiple values.
   overriding
   procedure Add_Header (Reply   : in out AWS_Http_Response;
                         Name    : in String;
                         Value   : in String) is
   begin
      null;
   end Add_Header;

   --  Iterate over the response headers and executes the Process procedure.
   overriding
   procedure Iterate_Headers (Reply   : in AWS_Http_Response;
                              Process : not null access
                                procedure (Name  : in String;
                                           Value : in String)) is
   begin
      null;
   end Iterate_Headers;

   --  ------------------------------
   --  Get the response body as a string.
   --  ------------------------------
   function Get_Body (Reply : in AWS_Http_Response) return String is
   begin
      return AWS.Response.Message_Body (Reply.Data);
   end Get_Body;

   --  Get the response status code.
   overriding
   function Get_Status (Reply : in AWS_Http_Response) return Natural is
   begin
      return To_Status (AWS.Response.Status_Code (Reply.Data));
   end Get_Status;

end Util.Http.Clients.Web;

-----------------------------------------------------------------------
--  util-http-clients-web -- HTTP Clients with AWS implementation
--  Copyright (C) 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 AWS.Headers.Set;
with AWS.Client;
with AWS.Messages;
package body Util.Http.Clients.Web is

   Manager : aliased AWS_Http_Manager;

   --  ------------------------------
   --  Register the Http manager.
   --  ------------------------------
   procedure Register is
   begin
      Default_Http_Manager := Manager'Access;
   end Register;

   function To_Status (Code : in AWS.Messages.Status_Code) return Natural;

   function To_Status (Code : in AWS.Messages.Status_Code) return Natural is
      use AWS.Messages;
   begin
      case Code is
         when S100 =>
            return 100;
         when S101 =>
            return 101;
         when S102 =>
            return 102;
         when S200 =>
            return 200;
         when S201 =>
            return 201;
         when S203 =>
            return 203;
         when S204 =>
            return 204;
         when S205 =>
            return 205;
         when S206 =>
            return 206;
         when S207 =>
            return 207;
         when S300 =>
            return 300;
         when S301 =>
            return 301;
         when S302 =>
            return 302;
         when S303 =>
            return 303;
         when S304 =>
            return 304;
         when S305 =>
            return 305;
         when S307 =>
            return 307;
         when S400 =>
            return 400;
         when S401 =>
            return 401;
         when S402 =>
            return 402;
         when S403 =>
            return 403;
         when S404 =>
            return 404;
         when S405 =>
            return 405;
         when S406 =>
            return 406;
         when S407 =>
            return 407;
         when S408 =>
            return 408;
         when S409 =>
            return 409;
         when S410 =>
            return 410;
         when S411 =>
            return 411;
         when S412 =>
            return 412;
         when S413 =>
            return 413;
         when S414 =>
            return 414;
         when S415 =>
            return 415;
         when S416 =>
            return 416;
         when S417 =>
            return 417;
         when S422 =>
            return 422;
         when S423 =>
            return 423;
         when S424 =>
            return 424;
         when S500 =>
            return 500;
         when S501 =>
            return 501;
         when S502 =>
            return 502;
         when S503 =>
            return 503;
         when S504 =>
            return 504;
         when S505 =>
            return 505;
         when S507 =>
            return 507;
         when others =>
            return 500;
      end case;
   end To_Status;

   procedure Create (Manager  : in AWS_Http_Manager;
                     Http     : in out Client'Class) is
      pragma Unreferenced (Manager);
   begin
      Http.Delegate := new AWS_Http_Request;
   end Create;

   procedure Do_Get (Manager  : in AWS_Http_Manager;
                     Http     : in Client'Class;
                     URI      : in String;
                     Reply    : out Response'Class) is
      pragma Unreferenced (Manager);

      Req     : constant AWS_Http_Request_Access
        := AWS_Http_Request'Class (Http.Delegate.all)'Access;
      Rep     : constant AWS_Http_Response_Access := new AWS_Http_Response;
   begin
      Reply.Delegate := Rep.all'Access;
      Rep.Data       := AWS.Client.Get (URL => URI, Headers => Req.Headers);
   end Do_Get;

   procedure Do_Post (Manager  : in AWS_Http_Manager;
                      Http     : in Client'Class;
                      URI      : in String;
                      Data     : in String;
                      Reply    : out Response'Class) is
      pragma Unreferenced (Manager);

      Req     : constant AWS_Http_Request_Access
        := AWS_Http_Request'Class (Http.Delegate.all)'Access;
      Rep     : constant AWS_Http_Response_Access := new AWS_Http_Response;
   begin
      Reply.Delegate := Rep.all'Access;
      Rep.Data       := AWS.Client.Post (URL => URI, Data => Data, Headers => Req.Headers);
   end Do_Post;

   --  ------------------------------
   --  Returns a boolean indicating whether the named request header has already
   --  been set.
   --  ------------------------------
   function Contains_Header (Http : in AWS_Http_Request;
                             Name : in String) return Boolean is
   begin
      raise Program_Error with "Contains_Header is not implemented";
      return False;
   end Contains_Header;

   --  Returns the value of the specified request header as a String. If the request
   --  did not include a header of the specified name, this method returns null.
   --  If there are multiple headers with the same name, this method returns the
   --  first head in the request. The header name is case insensitive. You can use
   --  this method with any response header.
   overriding
   function Get_Header (Request : in AWS_Http_Request;
                        Name    : in String) return String is
   begin
      return "";
   end Get_Header;

   --  ------------------------------
   --  Sets a request header with the given name and value. If the header had already
   --  been set, the new value overwrites the previous one. The containsHeader
   --  method can be used to test for the presence of a header before setting its value.
   --  ------------------------------
   overriding
   procedure Set_Header (Http  : in out AWS_Http_Request;
                         Name  : in String;
                         Value : in String) is
   begin
      AWS.Headers.Set.Add (Http.Headers, Name, Value);
   end Set_Header;

   --  ------------------------------
   --  Adds a request header with the given name and value.
   --  This method allows request headers to have multiple values.
   --  ------------------------------
   overriding
   procedure Add_Header (Http  : in out AWS_Http_Request;
                         Name  : in String;
                         Value : in String) is
   begin
      AWS.Headers.Set.Add (Http.Headers, Name, Value);
   end Add_Header;

   --  Iterate over the request headers and executes the Process procedure.
   overriding
   procedure Iterate_Headers (Request : in AWS_Http_Request;
                              Process : not null access
                                procedure (Name  : in String;
                                           Value : in String)) is
   begin
      null;
   end Iterate_Headers;

   --  ------------------------------
   --  Returns a boolean indicating whether the named response header has already
   --  been set.
   --  ------------------------------
   function Contains_Header (Reply : in AWS_Http_Response;
                             Name  : in String) return Boolean is
   begin
      return AWS.Response.Header (Reply.Data, Name) /= "";
   end Contains_Header;

   --  ------------------------------
   --  Returns the value of the specified response header as a String. If the response
   --  did not include a header of the specified name, this method returns null.
   --  If there are multiple headers with the same name, this method returns the
   --  first head in the request. The header name is case insensitive. You can use
   --  this method with any response header.
   --  ------------------------------
   function Get_Header (Reply  : in AWS_Http_Response;
                        Name   : in String) return String is
   begin
      return AWS.Response.Header (Reply.Data, Name);
   end Get_Header;

   --  Sets a message header with the given name and value. If the header had already
   --  been set, the new value overwrites the previous one. The containsHeader
   --  method can be used to test for the presence of a header before setting its value.
   overriding
   procedure Set_Header (Reply    : in out AWS_Http_Response;
                         Name     : in String;
                         Value    : in String) is
   begin
      null;
   end Set_Header;

   --  Adds a request header with the given name and value.
   --  This method allows request headers to have multiple values.
   overriding
   procedure Add_Header (Reply   : in out AWS_Http_Response;
                         Name    : in String;
                         Value   : in String) is
   begin
      null;
   end Add_Header;

   --  Iterate over the response headers and executes the Process procedure.
   overriding
   procedure Iterate_Headers (Reply   : in AWS_Http_Response;
                              Process : not null access
                                procedure (Name  : in String;
                                           Value : in String)) is
   begin
      null;
   end Iterate_Headers;

   --  ------------------------------
   --  Get the response body as a string.
   --  ------------------------------
   function Get_Body (Reply : in AWS_Http_Response) return String is
   begin
      return AWS.Response.Message_Body (Reply.Data);
   end Get_Body;

   --  Get the response status code.
   overriding
   function Get_Status (Reply : in AWS_Http_Response) return Natural is
   begin
      return To_Status (AWS.Response.Status_Code (Reply.Data));
   end Get_Status;

end Util.Http.Clients.Web;

Fix comment header

Fix comment header


-----------------------------------------------------------------------
--  asf-routes-tests - Unit tests for ASF.Routes
--  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 Util.Measures;
with Util.Log.Loggers;
with Util.Test_Caller;

with EL.Contexts.Default;
package body ASF.Routes.Tests is

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("ASF.Routes.Tests");

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test ASF.Routes.Add_Route (fixed path)",
                       Test_Add_Route_With_Path'Access);
      Caller.Add_Test (Suite, "Test ASF.Routes.Add_Route (:param path)",
                       Test_Add_Route_With_Param'Access);
      Caller.Add_Test (Suite, "Test ASF.Routes.Add_Route (*.ext path)",
                       Test_Add_Route_With_Ext'Access);
      Caller.Add_Test (Suite, "Test ASF.Routes.Add_Route (#{} path)",
                       Test_Add_Route_With_EL'Access);
      Caller.Add_Test (Suite, "Test ASF.Routes.Iterate",
                       Test_Iterate'Access);
   end Add_Tests;

   overriding
   function Get_Value (Bean : in Test_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "id" then
         return Util.Beans.Objects.To_Object (Bean.Id);
      elsif Name = "name" then
         return Util.Beans.Objects.To_Object (Bean.Name);
      else
         return Util.Beans.Objects.Null_Object;
      end if;
   end Get_Value;

   overriding
   procedure Set_Value (Bean  : in out Test_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = "id" then
         Bean.Id := Util.Beans.Objects.To_Unbounded_String (Value);
      elsif Name = "name" then
         Bean.Name := Util.Beans.Objects.To_Unbounded_String (Value);
      end if;
   end Set_Value;

   --  ------------------------------
   --  Setup the test instance.
   --  ------------------------------
   overriding
   procedure Set_Up (T : in out Test) is
   begin
      T.Bean := new Test_Bean;
      ASF.Tests.EL_Test (T).Set_Up;
      T.Root_Resolver.Register (Ada.Strings.Unbounded.To_Unbounded_String ("user"),
                                Util.Beans.Objects.To_Object (T.Bean.all'Access));
      for I in T.Routes'Range loop
         T.Routes (I) := new Test_Route_Type '(Index => I);
      end loop;
   end Set_Up;

   --  ------------------------------
   --  Verify that the path matches the given route.
   --  ------------------------------
   procedure Verify_Route (T      : in out Test;
                           Router : in out Router_Type;
                           Path   : in String;
                           Index  : in Positive;
                           Bean   : in out Test_Bean'Class) is
      Route   : constant Route_Type_Access := T.Routes (Index).all'Access;
      R       : Route_Context_Type;
   begin
      Router.Find_Route (Path, R);
      declare
         P : constant String := Get_Path (R);
      begin
         T.Assert_Equals (Path, P, "Add_Route + Find_Route with " & Path);
         T.Assert (Get_Route (R) /= null, "Get_Route returns a null route for " & Path);
         T.Assert (Get_Route (R) = Route, "Get_Route returns a wrong route for " & Path);

         --  Inject the path parameters in the bean instance.
         Inject_Parameters (R, Bean, T.ELContext.all);
      end;
   end Verify_Route;

   --  ------------------------------
   --  Add the route associted with the path pattern.
   --  ------------------------------
   procedure Add_Route (T      : in out Test;
                        Router : in out Router_Type;
                        Path   : in String;
                        Index  : in Positive;
                        Bean   : in out Test_Bean'Class) is
      Route   : constant Route_Type_Access := T.Routes (Index).all'Access;
   begin
      Router.Add_Route (Path, Route, T.ELContext.all);
      Verify_Route (T, Router, Path, Index, Bean);
   end Add_Route;

   --  ------------------------------
   --  Test the Add_Route with simple fixed path components.
   --  Example: /list/index.html
   --  ------------------------------
   procedure Test_Add_Route_With_Path (T : in out Test) is
      Router  : Router_Type;
      Bean    : Test_Bean;
   begin
      Add_Route (T, Router, "/page.html", 1, Bean);
      Add_Route (T, Router, "/list/page.html", 2, Bean);
      Add_Route (T, Router, "/list/index.html", 3, Bean);
      Add_Route (T, Router, "/view/page/content/index.html", 4, Bean);
      Add_Route (T, Router, "/list//page/view.html", 5, Bean);
      Add_Route (T, Router, "/list////page/content.html", 6, Bean);

      Verify_Route (T, Router, "/list/index.html", 3, Bean);
   end Test_Add_Route_With_Path;

   --  ------------------------------
   --  Test the Add_Route with extension mapping.
   --  Example: /list/*.html
   --  ------------------------------
   procedure Test_Add_Route_With_Ext (T : in out Test) is
      Router  : Router_Type;
      Bean    : Test_Bean;
   begin
      Add_Route (T, Router, "/page.html", 1, Bean);
      Add_Route (T, Router, "/list/*.html", 2, Bean);
      Add_Route (T, Router, "/list/index.html", 3, Bean);
      Add_Route (T, Router, "/view/page/content/page1.html", 4, Bean);
      Add_Route (T, Router, "/view/page/content/page2.html", 5, Bean);
      Add_Route (T, Router, "/view/page/content/*.html", 6, Bean);
      Add_Route (T, Router, "/ajax/*", 7, Bean);
      Add_Route (T, Router, "*.html", 8, Bean);

      --  Verify precedence and wildcard matching.
      Verify_Route (T, Router, "/list/index.html", 3, Bean);
      Verify_Route (T, Router, "/list/admin.html", 2, Bean);
      Verify_Route (T, Router, "/list/1/2/3/admin.html", 2, Bean);
      Verify_Route (T, Router, "/view/page/content/t.html", 6, Bean);
      Verify_Route (T, Router, "/view/page/content/1/t.html", 6, Bean);
      Verify_Route (T, Router, "/view/page/content/1/2/t.html", 6, Bean);
      Verify_Route (T, Router, "/ajax/form/save", 7, Bean);
      Verify_Route (T, Router, "/view/index.html", 8, Bean);
   end Test_Add_Route_With_Ext;

   --  ------------------------------
   --  Test the Add_Route with fixed path components and path parameters.
   --  Example: /users/:id/view.html
   --  ------------------------------
   procedure Test_Add_Route_With_Param (T : in out Test) is
      use Ada.Strings.Unbounded;

      Router  : Router_Type;
      Bean    : Test_Bean;
   begin
      Add_Route (T, Router, "/users/:id/view.html", 1, Bean);
      T.Assert_Equals (":id", To_String (Bean.Id), "Bean injection failed for :id");

      Bean.Id := To_Unbounded_String ("");
      Add_Route (T, Router, "/users/:id/list.html", 2, Bean);
      T.Assert_Equals (":id", To_String (Bean.Id), "Bean injection failed for :id");

      Bean.Id := To_Unbounded_String ("");
      Add_Route (T, Router, "/users/:id/index.html", 3, Bean);
      T.Assert_Equals (":id", To_String (Bean.Id), "Bean injection failed for :id");

      Bean.Id := To_Unbounded_String ("");
      Add_Route (T, Router, "/view/page/content/index.html", 4, Bean);
      Add_Route (T, Router, "/list//page/view.html", 5, Bean);
      Add_Route (T, Router, "/list////page/content.html", 6, Bean);
      T.Assert_Equals ("", To_String (Bean.Id), "Bean injection failed for fixed path");

      Add_Route (T, Router, "/users/:id/:name/index.html", 7, Bean);
      T.Assert_Equals (":id", To_String (Bean.Id), "Bean injection failed for :id");
      T.Assert_Equals (":name", To_String (Bean.Name), "Bean injection failed for :name");

      Add_Route (T, Router, "/users/list/index.html", 8, Bean);

      Verify_Route (T, Router, "/users/1234/view.html", 1, Bean);
      T.Assert_Equals ("1234", To_String (Bean.Id), "Bean injection failed for :id");

      Verify_Route (T, Router, "/users/234/567/index.html", 7, Bean);
      T.Assert_Equals ("234", To_String (Bean.Id), "Bean injection failed for :id");
      T.Assert_Equals ("567", To_String (Bean.Name), "Bean injection failed for :name");

   end Test_Add_Route_With_Param;

   --  ------------------------------
   --  Test the Add_Route with fixed path components and EL path injection.
   --  Example: /users/#{user.id}/view.html
   --  ------------------------------
   procedure Test_Add_Route_With_EL (T : in out Test) is
            use Ada.Strings.Unbounded;

      Router  : Router_Type;
      Bean    : aliased Test_Bean;
   begin
      Add_Route (T, Router, "/users/#{user.id}", 1, Bean);
      Add_Route (T, Router, "/users/view.html", 2, Bean);
      Add_Route (T, Router, "/users/#{user.id}/#{user.name}/index.html", 3, Bean);
      Add_Route (T, Router, "/users/admin/#{user.id}/pages/#{user.name}", 4, Bean);

      --  Verify that the path parameters are injected in the 'user' bean (= T.Bean).
      Verify_Route (T, Router, "/users/234/567/index.html", 3, Bean);
      T.Assert_Equals ("234", To_String (T.Bean.Id), "Bean injection failed for :id");
      T.Assert_Equals ("567", To_String (T.Bean.Name), "Bean injection failed for :name");

   end Test_Add_Route_With_EL;

   P_1 : aliased constant String := "/list/index.html";
   P_2 : aliased constant String := "/users/:id";
   P_3 : aliased constant String := "/users/:id/view";
   P_4 : aliased constant String := "/users/index.html";
   P_5 : aliased constant String := "/users/:id/:name";
   P_6 : aliased constant String := "/users/:id/:name/view.html";
   P_7 : aliased constant String := "/users/:id/list";
   P_8 : aliased constant String := "/users/test.html";
   P_9 : aliased constant String := "/admin/1/2/3/4/5/list.html";
   P_10 : aliased constant String := "/admin/*.html";
   P_11 : aliased constant String := "/admin/*.png";
   P_12 : aliased constant String := "/admin/*.jpg";
   P_13 : aliased constant String := "/users/:id/page/*.xml";
   P_14 : aliased constant String := "/*.jsf";

   type Const_String_Access is access constant String;

   type String_Array is array (Positive range <>) of Const_String_Access;

   Path_Array : constant String_Array :=
     (P_1'Access, P_2'Access, P_3'Access, P_4'Access,
      P_5'Access, P_6'Access, P_7'Access, P_8'Access,
      P_9'Access, P_10'Access, P_11'Access, P_12'Access,
      P_13'Access, P_14'Access);

   --  ------------------------------
   --  Test the Iterate over several paths.
   --  ------------------------------
   procedure Test_Iterate (T : in out Test) is
      Router  : Router_Type;
      Bean    : Test_Bean;

      procedure Process (Pattern : in String;
                         Route   : in Route_Type_Access) is
      begin
         T.Assert (Route /= null, "The route is null for " & Pattern);
         T.Assert (Route.all in Test_Route_Type'Class, "Invalid route for " & Pattern);

         Log.Info ("Route {0} to {1}", Pattern, Natural'Image (Test_Route_Type (Route.all).Index));
         T.Assert_Equals (Pattern, Path_Array (Test_Route_Type (Route.all).Index).all,
                          "Invalid route for " & Pattern);
      end Process;

   begin
      for I in Path_Array'Range loop
         Add_Route (T, Router, Path_Array (I).all, I, Bean);
      end loop;
      Router.Iterate (Process'Access);

      declare
         R  : Route_Context_Type;
         St : Util.Measures.Stamp;
      begin
         for I in 1 .. 1000 loop
            declare
               R : Route_Context_Type;
            begin
               Router.Find_Route ("/admin/1/2/3/4/5/list.html", R);
            end;
         end loop;
         Util.Measures.Report (St, "Find 1000 routes (fixed path)");
      end;

      declare
         R  : Route_Context_Type;
         St : Util.Measures.Stamp;
      begin
         for I in 1 .. 1000 loop
            declare
               R : Route_Context_Type;
            begin
               Router.Find_Route ("/admin/1/2/3/4/5/list.jsf", R);
            end;
         end loop;
         Util.Measures.Report (St, "Find 1000 routes (extension)");
      end;
   end Test_Iterate;

end ASF.Routes.Tests;

-----------------------------------------------------------------------
--  asf-routes-tests - Unit tests for ASF.Routes
--  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 Util.Measures;
with Util.Log.Loggers;
with Util.Test_Caller;

with EL.Contexts.Default;
package body ASF.Routes.Tests is

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("ASF.Routes.Tests");

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test ASF.Routes.Add_Route (fixed path)",
                       Test_Add_Route_With_Path'Access);
      Caller.Add_Test (Suite, "Test ASF.Routes.Add_Route (:param path)",
                       Test_Add_Route_With_Param'Access);
      Caller.Add_Test (Suite, "Test ASF.Routes.Add_Route (*.ext path)",
                       Test_Add_Route_With_Ext'Access);
      Caller.Add_Test (Suite, "Test ASF.Routes.Add_Route (#{} path)",
                       Test_Add_Route_With_EL'Access);
      Caller.Add_Test (Suite, "Test ASF.Routes.Iterate",
                       Test_Iterate'Access);
   end Add_Tests;

   overriding
   function Get_Value (Bean : in Test_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "id" then
         return Util.Beans.Objects.To_Object (Bean.Id);
      elsif Name = "name" then
         return Util.Beans.Objects.To_Object (Bean.Name);
      else
         return Util.Beans.Objects.Null_Object;
      end if;
   end Get_Value;

   overriding
   procedure Set_Value (Bean  : in out Test_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = "id" then
         Bean.Id := Util.Beans.Objects.To_Unbounded_String (Value);
      elsif Name = "name" then
         Bean.Name := Util.Beans.Objects.To_Unbounded_String (Value);
      end if;
   end Set_Value;

   --  ------------------------------
   --  Setup the test instance.
   --  ------------------------------
   overriding
   procedure Set_Up (T : in out Test) is
   begin
      T.Bean := new Test_Bean;
      ASF.Tests.EL_Test (T).Set_Up;
      T.Root_Resolver.Register (Ada.Strings.Unbounded.To_Unbounded_String ("user"),
                                Util.Beans.Objects.To_Object (T.Bean.all'Access));
      for I in T.Routes'Range loop
         T.Routes (I) := Route_Type_Refs.Create (new Test_Route_Type '(Util.Refs.Ref_Entity with Index => I));
      end loop;
   end Set_Up;

   --  ------------------------------
   --  Verify that the path matches the given route.
   --  ------------------------------
   procedure Verify_Route (T      : in out Test;
                           Router : in out Router_Type;
                           Path   : in String;
                           Index  : in Positive;
                           Bean   : in out Test_Bean'Class) is
      Route   : constant Route_Type_Access := T.Routes (Index).Value;
      R       : Route_Context_Type;
   begin
      Router.Find_Route (Path, R);
      declare
         P : constant String := Get_Path (R);
      begin
         T.Assert_Equals (Path, P, "Add_Route + Find_Route with " & Path);
         T.Assert (Get_Route (R) /= null, "Get_Route returns a null route for " & Path);
         T.Assert (Get_Route (R) = Route, "Get_Route returns a wrong route for " & Path);

         --  Inject the path parameters in the bean instance.
         Inject_Parameters (R, Bean, T.ELContext.all);
      end;
   end Verify_Route;

   --  ------------------------------
   --  Add the route associted with the path pattern.
   --  ------------------------------
   procedure Add_Route (T      : in out Test;
                        Router : in out Router_Type;
                        Path   : in String;
                        Index  : in Positive;
                        Bean   : in out Test_Bean'Class) is
      Route   : constant Route_Type_Access := T.Routes (Index).Value;
   begin
      Router.Add_Route (Path, Route, T.ELContext.all);
      Verify_Route (T, Router, Path, Index, Bean);
   end Add_Route;

   --  ------------------------------
   --  Test the Add_Route with simple fixed path components.
   --  Example: /list/index.html
   --  ------------------------------
   procedure Test_Add_Route_With_Path (T : in out Test) is
      Router  : Router_Type;
      Bean    : Test_Bean;
   begin
      Add_Route (T, Router, "/page.html", 1, Bean);
      Add_Route (T, Router, "/list/page.html", 2, Bean);
      Add_Route (T, Router, "/list/index.html", 3, Bean);
      Add_Route (T, Router, "/view/page/content/index.html", 4, Bean);
      Add_Route (T, Router, "/list//page/view.html", 5, Bean);
      Add_Route (T, Router, "/list////page/content.html", 6, Bean);

      Verify_Route (T, Router, "/list/index.html", 3, Bean);
   end Test_Add_Route_With_Path;

   --  ------------------------------
   --  Test the Add_Route with extension mapping.
   --  Example: /list/*.html
   --  ------------------------------
   procedure Test_Add_Route_With_Ext (T : in out Test) is
      Router  : Router_Type;
      Bean    : Test_Bean;
   begin
      Add_Route (T, Router, "/page.html", 1, Bean);
      Add_Route (T, Router, "/list/*.html", 2, Bean);
      Add_Route (T, Router, "/list/index.html", 3, Bean);
      Add_Route (T, Router, "/view/page/content/page1.html", 4, Bean);
      Add_Route (T, Router, "/view/page/content/page2.html", 5, Bean);
      Add_Route (T, Router, "/view/page/content/*.html", 6, Bean);
      Add_Route (T, Router, "/ajax/*", 7, Bean);
      Add_Route (T, Router, "*.html", 8, Bean);

      --  Verify precedence and wildcard matching.
      Verify_Route (T, Router, "/list/index.html", 3, Bean);
      Verify_Route (T, Router, "/list/admin.html", 2, Bean);
      Verify_Route (T, Router, "/list/1/2/3/admin.html", 2, Bean);
      Verify_Route (T, Router, "/view/page/content/t.html", 6, Bean);
      Verify_Route (T, Router, "/view/page/content/1/t.html", 6, Bean);
      Verify_Route (T, Router, "/view/page/content/1/2/t.html", 6, Bean);
      Verify_Route (T, Router, "/ajax/form/save", 7, Bean);
      Verify_Route (T, Router, "/view/index.html", 8, Bean);
   end Test_Add_Route_With_Ext;

   --  ------------------------------
   --  Test the Add_Route with fixed path components and path parameters.
   --  Example: /users/:id/view.html
   --  ------------------------------
   procedure Test_Add_Route_With_Param (T : in out Test) is
      use Ada.Strings.Unbounded;

      Router  : Router_Type;
      Bean    : Test_Bean;
   begin
      Add_Route (T, Router, "/users/:id/view.html", 1, Bean);
      T.Assert_Equals (":id", To_String (Bean.Id), "Bean injection failed for :id");

      Bean.Id := To_Unbounded_String ("");
      Add_Route (T, Router, "/users/:id/list.html", 2, Bean);
      T.Assert_Equals (":id", To_String (Bean.Id), "Bean injection failed for :id");

      Bean.Id := To_Unbounded_String ("");
      Add_Route (T, Router, "/users/:id/index.html", 3, Bean);
      T.Assert_Equals (":id", To_String (Bean.Id), "Bean injection failed for :id");

      Bean.Id := To_Unbounded_String ("");
      Add_Route (T, Router, "/view/page/content/index.html", 4, Bean);
      Add_Route (T, Router, "/list//page/view.html", 5, Bean);
      Add_Route (T, Router, "/list////page/content.html", 6, Bean);
      T.Assert_Equals ("", To_String (Bean.Id), "Bean injection failed for fixed path");

      Add_Route (T, Router, "/users/:id/:name/index.html", 7, Bean);
      T.Assert_Equals (":id", To_String (Bean.Id), "Bean injection failed for :id");
      T.Assert_Equals (":name", To_String (Bean.Name), "Bean injection failed for :name");

      Add_Route (T, Router, "/users/list/index.html", 8, Bean);

      Verify_Route (T, Router, "/users/1234/view.html", 1, Bean);
      T.Assert_Equals ("1234", To_String (Bean.Id), "Bean injection failed for :id");

      Verify_Route (T, Router, "/users/234/567/index.html", 7, Bean);
      T.Assert_Equals ("234", To_String (Bean.Id), "Bean injection failed for :id");
      T.Assert_Equals ("567", To_String (Bean.Name), "Bean injection failed for :name");

   end Test_Add_Route_With_Param;

   --  ------------------------------
   --  Test the Add_Route with fixed path components and EL path injection.
   --  Example: /users/#{user.id}/view.html
   --  ------------------------------
   procedure Test_Add_Route_With_EL (T : in out Test) is
            use Ada.Strings.Unbounded;

      Router  : Router_Type;
      Bean    : aliased Test_Bean;
   begin
      Add_Route (T, Router, "/users/#{user.id}", 1, Bean);
      Add_Route (T, Router, "/users/view.html", 2, Bean);
      Add_Route (T, Router, "/users/#{user.id}/#{user.name}/index.html", 3, Bean);
      Add_Route (T, Router, "/users/admin/#{user.id}/pages/#{user.name}", 4, Bean);

      --  Verify that the path parameters are injected in the 'user' bean (= T.Bean).
      Verify_Route (T, Router, "/users/234/567/index.html", 3, Bean);
      T.Assert_Equals ("234", To_String (T.Bean.Id), "Bean injection failed for :id");
      T.Assert_Equals ("567", To_String (T.Bean.Name), "Bean injection failed for :name");

   end Test_Add_Route_With_EL;

   P_1 : aliased constant String := "/list/index.html";
   P_2 : aliased constant String := "/users/:id";
   P_3 : aliased constant String := "/users/:id/view";
   P_4 : aliased constant String := "/users/index.html";
   P_5 : aliased constant String := "/users/:id/:name";
   P_6 : aliased constant String := "/users/:id/:name/view.html";
   P_7 : aliased constant String := "/users/:id/list";
   P_8 : aliased constant String := "/users/test.html";
   P_9 : aliased constant String := "/admin/1/2/3/4/5/list.html";
   P_10 : aliased constant String := "/admin/*.html";
   P_11 : aliased constant String := "/admin/*.png";
   P_12 : aliased constant String := "/admin/*.jpg";
   P_13 : aliased constant String := "/users/:id/page/*.xml";
   P_14 : aliased constant String := "/*.jsf";

   type Const_String_Access is access constant String;

   type String_Array is array (Positive range <>) of Const_String_Access;

   Path_Array : constant String_Array :=
     (P_1'Access, P_2'Access, P_3'Access, P_4'Access,
      P_5'Access, P_6'Access, P_7'Access, P_8'Access,
      P_9'Access, P_10'Access, P_11'Access, P_12'Access,
      P_13'Access, P_14'Access);

   --  ------------------------------
   --  Test the Iterate over several paths.
   --  ------------------------------
   procedure Test_Iterate (T : in out Test) is
      Router  : Router_Type;
      Bean    : Test_Bean;

      procedure Process (Pattern : in String;
                         Route   : in Route_Type_Access) is
      begin
         T.Assert (Route /= null, "The route is null for " & Pattern);
         T.Assert (Route.all in Test_Route_Type'Class, "Invalid route for " & Pattern);

         Log.Info ("Route {0} to {1}", Pattern, Natural'Image (Test_Route_Type (Route.all).Index));
         T.Assert_Equals (Pattern, Path_Array (Test_Route_Type (Route.all).Index).all,
                          "Invalid route for " & Pattern);
      end Process;

   begin
      for I in Path_Array'Range loop
         Add_Route (T, Router, Path_Array (I).all, I, Bean);
      end loop;
      Router.Iterate (Process'Access);

      declare
         R  : Route_Context_Type;
         St : Util.Measures.Stamp;
      begin
         for I in 1 .. 1000 loop
            declare
               R : Route_Context_Type;
            begin
               Router.Find_Route ("/admin/1/2/3/4/5/list.html", R);
            end;
         end loop;
         Util.Measures.Report (St, "Find 1000 routes (fixed path)");
      end;

      declare
         R  : Route_Context_Type;
         St : Util.Measures.Stamp;
      begin
         for I in 1 .. 1000 loop
            declare
               R : Route_Context_Type;
            begin
               Router.Find_Route ("/admin/1/2/3/4/5/list.jsf", R);
            end;
         end loop;
         Util.Measures.Report (St, "Find 1000 routes (extension)");
      end;
   end Test_Iterate;

end ASF.Routes.Tests;

Update the unit tests

Update the unit tests


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

with Util.Processes;

--  === Pipes ===
--  The Util.Streams.Pipes package defines a pipe stream to or from a process.
--  The process is created and launched by the Open operation.  The pipe allows
--  to read or write to the process through the Read and Write operation.
package Util.Streams.Pipes is

   use Util.Processes;

   subtype Pipe_Mode is Util.Processes.Pipe_Mode range READ .. READ_WRITE;

   --  -----------------------
   --  Pipe stream
   --  -----------------------
   --  The Pipe_Stream is an output/input stream that reads or writes
   --  to or from a process.
   type Pipe_Stream is limited new Output_Stream and Input_Stream  with private;

   --  Set the shell executable path to use to launch a command.  The default on Unix is
   --  the /bin/sh command.  Argument splitting is done by the /bin/sh -c command.
   --  When setting an empty shell command, the argument splitting is done by the
   --  <tt>Spawn</tt> procedure.
   procedure Set_Shell (Stream : in out Pipe_Stream;
                        Shell  : in String);

   --  Before launching the process, redirect the input stream of the process
   --  to the specified file.
   --  Raises Invalid_State if the process is running.
   procedure Set_Input_Stream (Stream : in out Pipe_Stream;
                               File   : in String);

   --  Set the output stream of the process.
   --  Raises Invalid_State if the process is running.
   procedure Set_Output_Stream (Stream : in out Pipe_Stream;
                                File   : in String;
                                Append : in Boolean := False);

   --  Set the error stream of the process.
   --  Raises Invalid_State if the process is running.
   procedure Set_Error_Stream (Stream : in out Pipe_Stream;
                               File   : in String;
                               Append : in Boolean := False);

   --  Set the working directory that the process will use once it is created.
   --  The directory must exist or the Invalid_Directory exception will be raised.
   procedure Set_Working_Directory (Stream : in out Pipe_Stream;
                                    Path   : in String);

   --  Open a pipe to read or write to an external process.  The pipe is created and the
   --  command is executed with the input and output streams redirected through the pipe.
   procedure Open (Stream  : in out Pipe_Stream;
                   Command : in String;
                   Mode    : in Pipe_Mode := READ);

   --  Close the pipe and wait for the external process to terminate.
   overriding
   procedure Close (Stream : in out Pipe_Stream);

   --  Get the process exit status.
   function Get_Exit_Status (Stream : in Pipe_Stream) return Integer;

   --  Returns True if the process is running.
   function Is_Running (Stream : in Pipe_Stream) return Boolean;

   --  Write the buffer array to the output stream.
   overriding
   procedure Write (Stream : in out Pipe_Stream;
                    Buffer : in Ada.Streams.Stream_Element_Array);

   --  Read into the buffer as many bytes as possible and return in
   --  last the position of the last byte read.
   overriding
   procedure Read (Stream : in out Pipe_Stream;
                   Into   : out Ada.Streams.Stream_Element_Array;
                   Last   : out Ada.Streams.Stream_Element_Offset);

private

   use Ada.Streams;

   type Pipe_Stream is limited new Ada.Finalization.Limited_Controlled
     and Output_Stream and Input_Stream with record
      Proc   : Util.Processes.Process;
   end record;

   --  Flush the stream and release the buffer.
   overriding
   procedure Finalize (Object : in out Pipe_Stream);

end Util.Streams.Pipes;

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

with Util.Processes;

--  === Pipes ===
--  The `Util.Streams.Pipes` package defines a pipe stream to or from a process.
--  It allows to launch an external program while getting the program standard output or
--  providing the program standard input.  The `Pipe_Stream` type represents the input or
--  output stream for the external program.  This is a portable interface that works on
--  Unix and Windows.
--
--  The process is created and launched by the `Open` operation.  The pipe allows
--  to read or write to the process through the `Read` and `Write` operation.
--  It is very close to the *popen* operation provided by the C stdio library.
--  First, create the pipe instance:
--
--    with Util.Streams.Pipes;
--    ...
--       Pipe : aliased Util.Streams.Pipes.Pipe_Stream;
--
--  The pipe instance can be associated with only one process at a time.
--  The process is launched by using the `Open` command and by specifying the command
--  to execute as well as the pipe redirection mode:
--
--  * `READ` to read the process standard output,
--  * `WRITE` to write the process standard input.
--
--  For example to run the `ls -l` command and read its output, we could run it by using:
--
--    Pipe.Open (Command => "ls -l", Mode => Util.Processes.READ);
--
--  The `Pipe_Stream` is not buffered and a buffer can be configured easily by using the
--  `Input_Buffer_Stream` type and doing:
--
--    with Util.Streams.Buffered;
--    ...
--       Buffer : Util.Streams.Buffered.Input_Buffer_Stream;
--       ...
--       Buffer.Initialize (Input => Pipe'Unchecked_Access, Size => 1024);
--
--  And to read the process output, one can use the following:
--
--     Content : Ada.Strings.Unbounded.Unbounded_String;
--     ...
--     Buffer.Read (Into => Content);
--
--  The pipe object should be closed when reading or writing to it is finished.
--  By closing the pipe, the caller will wait for the termination of the process.
--  The process exit status can be obtained by using the `Get_Exit_Status` function.
--
--     Pipe.Close;
--     if Pipe.Get_Exit_Status /= 0 then
--        Ada.Text_IO.Put_Line ("Command exited with status "
--                              & Integer'Image (Pipe.Get_Exit_Status));
--     end if;
--
--  You will note that the `Pipe_Stream` is a limited type and thus cannot be copied.
--  When leaving the scope of the `Pipe_Stream` instance, the application will wait for
--  the process to terminate.
package Util.Streams.Pipes is

   use Util.Processes;

   subtype Pipe_Mode is Util.Processes.Pipe_Mode range READ .. READ_WRITE;

   --  -----------------------
   --  Pipe stream
   --  -----------------------
   --  The Pipe_Stream is an output/input stream that reads or writes
   --  to or from a process.
   type Pipe_Stream is limited new Output_Stream and Input_Stream  with private;

   --  Set the shell executable path to use to launch a command.  The default on Unix is
   --  the /bin/sh command.  Argument splitting is done by the /bin/sh -c command.
   --  When setting an empty shell command, the argument splitting is done by the
   --  <tt>Spawn</tt> procedure.
   procedure Set_Shell (Stream : in out Pipe_Stream;
                        Shell  : in String);

   --  Before launching the process, redirect the input stream of the process
   --  to the specified file.
   --  Raises Invalid_State if the process is running.
   procedure Set_Input_Stream (Stream : in out Pipe_Stream;
                               File   : in String);

   --  Set the output stream of the process.
   --  Raises Invalid_State if the process is running.
   procedure Set_Output_Stream (Stream : in out Pipe_Stream;
                                File   : in String;
                                Append : in Boolean := False);

   --  Set the error stream of the process.
   --  Raises Invalid_State if the process is running.
   procedure Set_Error_Stream (Stream : in out Pipe_Stream;
                               File   : in String;
                               Append : in Boolean := False);

   --  Set the working directory that the process will use once it is created.
   --  The directory must exist or the Invalid_Directory exception will be raised.
   procedure Set_Working_Directory (Stream : in out Pipe_Stream;
                                    Path   : in String);

   --  Open a pipe to read or write to an external process.  The pipe is created and the
   --  command is executed with the input and output streams redirected through the pipe.
   procedure Open (Stream  : in out Pipe_Stream;
                   Command : in String;
                   Mode    : in Pipe_Mode := READ);

   --  Close the pipe and wait for the external process to terminate.
   overriding
   procedure Close (Stream : in out Pipe_Stream);

   --  Get the process exit status.
   function Get_Exit_Status (Stream : in Pipe_Stream) return Integer;

   --  Returns True if the process is running.
   function Is_Running (Stream : in Pipe_Stream) return Boolean;

   --  Write the buffer array to the output stream.
   overriding
   procedure Write (Stream : in out Pipe_Stream;
                    Buffer : in Ada.Streams.Stream_Element_Array);

   --  Read into the buffer as many bytes as possible and return in
   --  last the position of the last byte read.
   overriding
   procedure Read (Stream : in out Pipe_Stream;
                   Into   : out Ada.Streams.Stream_Element_Array;
                   Last   : out Ada.Streams.Stream_Element_Offset);

private

   use Ada.Streams;

   type Pipe_Stream is limited new Ada.Finalization.Limited_Controlled
     and Output_Stream and Input_Stream with record
      Proc   : Util.Processes.Process;
   end record;

   --  Flush the stream and release the buffer.
   overriding
   procedure Finalize (Object : in out Pipe_Stream);

end Util.Streams.Pipes;

Document the pipe streams

Document the pipe streams


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

with Util.Encoders.Base64;
package body Util.Streams.Buffered.Encoders is

   --  -----------------------
   --  Initialize the stream to write on the given stream.
   --  An internal buffer is allocated for writing the stream.
   --  -----------------------
   procedure Initialize (Stream  : in out Encoding_Stream;
                         Output  : in Output_Stream_Access;
                         Size    : in Natural;
                         Format  : in String) is
   begin
      Stream.Initialize (Output, Size);
      Stream.Transform := new Util.Encoders.Base64.Encoder;
   end Initialize;

   --  -----------------------
   --  Close the sink.
   --  -----------------------
   overriding
   procedure Close (Stream : in out Encoding_Stream) is
   begin
      Stream.Flush;
      Stream.Output.Close;
   end Close;

   --  -----------------------
   --  Write the buffer array to the output stream.
   --  -----------------------
   overriding
   procedure Write (Stream : in out Encoding_Stream;
                    Buffer : in Ada.Streams.Stream_Element_Array) is
      First_Encoded : Ada.Streams.Stream_Element_Offset := Buffer'First;
      Last_Encoded  : Ada.Streams.Stream_Element_Offset;
      Last_Pos      : Ada.Streams.Stream_Element_Offset;
   begin
      while First_Encoded <= Buffer'Last loop
         Stream.Transform.Transform
           (Data    => Buffer (First_Encoded .. Buffer'Last),
            Into    => Stream.Buffer (Stream.Write_Pos .. Stream.Buffer'Last),
            Last    => Last_Pos,
            Encoded => Last_Encoded);
         if Last_Encoded < Buffer'Last then
            Stream.Output.Write (Stream.Buffer (Stream.Buffer'First .. Last_Pos));
            Stream.Write_Pos := Stream.Buffer'First;
         else
            Stream.Write_Pos := Last_Pos + 1;
         end if;
         First_Encoded := Last_Encoded + 1;
      end loop;
   end Write;

   --  -----------------------
   --  Flush the buffer by writing on the output stream.
   --  Raises Data_Error if there is no output stream.
   --  -----------------------
   overriding
   procedure Flush (Stream : in out Encoding_Stream) is
      Last_Pos : Ada.Streams.Stream_Element_Offset;
   begin
      Stream.Transform.Finish (Stream.Buffer (Stream.Write_Pos .. Stream.Buffer'Last),
                               Last_Pos);
      Stream.Write_Pos := Last_Pos + 1;
      Output_Buffer_Stream (Stream).Flush;
   end Flush;

   --  -----------------------
   --  Flush the stream and release the buffer.
   --  -----------------------
   overriding
   procedure Finalize (Object : in out Encoding_Stream) is
   begin
      null;
   end Finalize;

end Util.Streams.Buffered.Encoders;

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

with Util.Encoders.Base64;
package body Util.Streams.Buffered.Encoders is

   --  -----------------------
   --  Initialize the stream to write on the given stream.
   --  An internal buffer is allocated for writing the stream.
   --  -----------------------
   procedure Initialize (Stream  : in out Encoding_Stream;
                         Output  : in Output_Stream_Access;
                         Size    : in Natural;
                         Format  : in String) is
      pragma Unreferenced (Format);
   begin
      Stream.Initialize (Output, Size);
      Stream.Transform := new Util.Encoders.Base64.Encoder;
   end Initialize;

   --  -----------------------
   --  Close the sink.
   --  -----------------------
   overriding
   procedure Close (Stream : in out Encoding_Stream) is
   begin
      Stream.Flush;
      Stream.Output.Close;
   end Close;

   --  -----------------------
   --  Write the buffer array to the output stream.
   --  -----------------------
   overriding
   procedure Write (Stream : in out Encoding_Stream;
                    Buffer : in Ada.Streams.Stream_Element_Array) is
      First_Encoded : Ada.Streams.Stream_Element_Offset := Buffer'First;
      Last_Encoded  : Ada.Streams.Stream_Element_Offset;
      Last_Pos      : Ada.Streams.Stream_Element_Offset;
   begin
      while First_Encoded <= Buffer'Last loop
         Stream.Transform.Transform
           (Data    => Buffer (First_Encoded .. Buffer'Last),
            Into    => Stream.Buffer (Stream.Write_Pos .. Stream.Buffer'Last),
            Last    => Last_Pos,
            Encoded => Last_Encoded);
         if Last_Encoded < Buffer'Last then
            Stream.Output.Write (Stream.Buffer (Stream.Buffer'First .. Last_Pos));
            Stream.Write_Pos := Stream.Buffer'First;
         else
            Stream.Write_Pos := Last_Pos + 1;
         end if;
         First_Encoded := Last_Encoded + 1;
      end loop;
   end Write;

   --  -----------------------
   --  Flush the buffer by writing on the output stream.
   --  Raises Data_Error if there is no output stream.
   --  -----------------------
   overriding
   procedure Flush (Stream : in out Encoding_Stream) is
      Last_Pos : Ada.Streams.Stream_Element_Offset := Stream.Write_Pos - 1;
   begin
      Stream.Transform.Finish (Stream.Buffer (Stream.Write_Pos .. Stream.Buffer'Last),
                               Last_Pos);
      Stream.Write_Pos := Last_Pos + 1;
      Output_Buffer_Stream (Stream).Flush;
   end Flush;

   --  -----------------------
   --  Flush the stream and release the buffer.
   --  -----------------------
   overriding
   procedure Finalize (Object : in out Encoding_Stream) is
   begin
      null;
   end Finalize;

end Util.Streams.Buffered.Encoders;

Fix compilation warning reported in the Flush procedure


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

package Definitions is

   pragma Pure;

   synth_version_major : constant String := "1";
   synth_version_minor : constant String := "41";
   copyright_years     : constant String := "2015-2016";
   host_localbase      : constant String := "/usr/local";
   host_pkg8           : constant String := host_localbase & "/sbin/pkg";
   jobs_per_cpu        : constant := 2;

   type cpu_range is range 1 .. 32;
   type scanners  is range cpu_range'First .. cpu_range'Last;
   type builders  is range cpu_range'First .. cpu_range'Last * jobs_per_cpu;

end Definitions;

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

package Definitions is

   pragma Pure;

   synth_version_major : constant String := "1";
   synth_version_minor : constant String := "42";
   copyright_years     : constant String := "2015-2016";
   host_localbase      : constant String := "/usr/local";
   host_pkg8           : constant String := host_localbase & "/sbin/pkg";
   jobs_per_cpu        : constant := 2;

   type cpu_range is range 1 .. 32;
   type scanners  is range cpu_range'First .. cpu_range'Last;
   type builders  is range cpu_range'First .. cpu_range'Last * jobs_per_cpu;

end Definitions;

Bump to version v1.42

Bump to version v1.42