-----------------------------------------------------------------------
--  security-policies -- Security Policies
--  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.Log.Loggers;

with Security.Controllers;
with Security.Contexts;

package body Security.Policies is

   use type Permissions.Permission_Index;

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Security.Policies");

   procedure Free is
     new Ada.Unchecked_Deallocation (Security.Controllers.Controller'Class,
                                     Security.Controllers.Controller_Access);

   --  ------------------------------
   --  Get the policy index.
   --  ------------------------------
   function Get_Policy_Index (From : in Policy'Class) return Policy_Index is
   begin
      return From.Index;
   end Get_Policy_Index;

   --  ------------------------------
   --  Add a permission under the given permission name and associated with the controller.
   --  To verify the permission, the controller will be called.
   --  ------------------------------
   procedure Add_Permission (Manager    : in out Policy;
                             Name       : in String;
                             Permission : in Controller_Access) is
   begin
      Manager.Manager.Add_Permission (Name, Permission);
   end Add_Permission;

   --  ------------------------------
   --  Get the policy with the name Name registered in the policy manager.
   --  Returns null if there is no such policy.
   --  ------------------------------
   function Get_Policy (Manager : in Policy_Manager;
                        Name    : in String) return Policy_Access is
   begin
      for I in Manager.Policies'Range loop
         if Manager.Policies (I) = null then
            return null;
         elsif Manager.Policies (I).Get_Name = Name then
            return Manager.Policies (I);
         end if;
      end loop;
      return null;
   end Get_Policy;

   --  ------------------------------
   --  Add the policy to the policy manager.  After a policy is added in the manager,
   --  it can participate in the security policy.
   --  Raises Policy_Error if the policy table is full.
   --  ------------------------------
   procedure Add_Policy (Manager : in out Policy_Manager;
                         Policy  : in Policy_Access) is
      Name : constant String := Policy.Get_Name;
   begin
      Log.Info ("Adding policy {0}", Name);

      for I in Manager.Policies'Range loop
         if Manager.Policies (I) = null then
            Manager.Policies (I) := Policy;
            Policy.Manager := Manager'Unchecked_Access;
            Policy.Index   := I;
            return;
         end if;
      end loop;
      Log.Error ("Policy table is full, increase policy manager table to {0} to add policy {1}",
                 Policy_Index'Image (Manager.Max_Policies + 1), Name);
      raise Policy_Error;
   end Add_Policy;

   --  ------------------------------
   --  Add a permission under the given permission name and associated with the controller.
   --  To verify the permission, the controller will be called.
   --  ------------------------------
   procedure Add_Permission (Manager    : in out Policy_Manager;
                             Name       : in String;
                             Permission : in Controller_Access) is
      Index : Permission_Index;
   begin
      Log.Info ("Adding permission {0}", Name);

      Permissions.Add_Permission (Name, Index);
      if Index >= Manager.Last_Index then
         declare
            Count : constant Permission_Index := Index + 32;
            Perms : constant Controller_Access_Array_Access
              := new Controller_Access_Array (0 .. Count);
         begin
            if Manager.Permissions /= null then
               Perms (Manager.Permissions'Range) := Manager.Permissions.all;
            end if;
            Manager.Permissions := Perms;
            Manager.Last_Index := Count;
         end;
      end if;

      --  If the permission has a controller, release it.
      if Manager.Permissions (Index) /= null then
         Log.Warn ("Permission {0} is redefined", Name);

         --  SCz 2011-12-03: GNAT 2011 reports a compilation error:
         --  'missing "with" clause on package "Security.Controllers"'
         --  if we use the 'Security.Controller_Access' type, even if this "with"
         --  clause exist.
         --  gcc 4.4.3 under Ubuntu does not have this issue.
         --  We use the 'Security.Controllers.Controller_Access' type to avoid the compiler
         --  bug but we have to use a temporary variable and do some type conversion...
         declare
            P : Security.Controllers.Controller_Access := Manager.Permissions (Index).all'Access;
         begin
            Free (P);
         end;
      end if;

      Manager.Permissions (Index) := Permission;
   end Add_Permission;

   --  ------------------------------
   --  Checks whether the permission defined by the Permission is granted
   --  for the security context passed in Context.
   --  Returns true if such permission is granted.
   --  ------------------------------
   function Has_Permission (Manager    : in Policy_Manager;
                            Context    : in Security.Contexts.Security_Context'Class;
                            Permission : in Security.Permissions.Permission'Class)
                            return Boolean is
   begin
      if Permission.Id >= Manager.Last_Index then
         return False;
      end if;
      declare
         C : constant Controller_Access := Manager.Permissions (Permission.Id);
      begin
         if C = null then
            return False;
         else
            return C.Has_Permission (Context, Permission);
         end if;
      end;
   end Has_Permission;

   --  ------------------------------
   --  Returns True if the security controller is defined for the given permission index.
   --  ------------------------------
   function Has_Controller (Manager : in Policy_Manager;
                            Index   : in Permissions.Permission_Index) return Boolean is
   begin
      return Index < Manager.Last_Index and then Manager.Permissions (Index) /= null;
   end Has_Controller;

   --  ------------------------------
   --  Create the policy contexts to be associated with the security context.
   --  ------------------------------
   function Create_Policy_Contexts (Manager : in Policy_Manager)
                                    return Policy_Context_Array_Access is
   begin
      return new Policy_Context_Array (1 .. Manager.Max_Policies);
   end Create_Policy_Contexts;

   --  ------------------------------
   --  Prepare the XML parser to read the policy configuration.
   --  ------------------------------
   procedure Prepare_Config (Manager : in out Policy_Manager;
                             Reader  : in out Util.Serialize.IO.XML.Parser) is
   begin
      --  Prepare the reader to parse the policy configuration.
      for I in Manager.Policies'Range loop
         exit when Manager.Policies (I) = null;
         Manager.Policies (I).Prepare_Config (Reader);
      end loop;
   end Prepare_Config;

   --  ------------------------------
   --  Finish reading the XML policy configuration.  The security policy implementation can use
   --  this procedure to perform any configuration setup after the configuration is parsed.
   --  ------------------------------
   procedure Finish_Config (Manager : in out Policy_Manager;
                            Reader  : in out Util.Serialize.IO.XML.Parser) is
   begin
      --  Finish the policy configuration.
      for I in Manager.Policies'Range loop
         exit when Manager.Policies (I) = null;
         Manager.Policies (I).Finish_Config (Reader);
      end loop;
   end Finish_Config;

   --  Read the policy file
   procedure Read_Policy (Manager : in out Policy_Manager;
                          File    : in String) is

      use Util;

      Reader : Util.Serialize.IO.XML.Parser;

      package Policy_Config is
        new Reader_Config (Reader, Manager'Unchecked_Access);
      pragma Warnings (Off, Policy_Config);
   begin
      Log.Info ("Reading policy file {0}", File);

      Manager.Prepare_Config (Reader);

      --  Read the configuration file.
      Reader.Parse (File);

      Manager.Finish_Config (Reader);
   end Read_Policy;

   --  ------------------------------
   --  Initialize the policy manager.
   --  ------------------------------
   overriding
   procedure Initialize (Manager : in out Policy_Manager) is
   begin
      null;
   end Initialize;

   --  ------------------------------
   --  Finalize the policy manager.
   --  ------------------------------
   overriding
   procedure Finalize (Manager : in out Policy_Manager) is
      procedure Free is
        new Ada.Unchecked_Deallocation (Controller_Access_Array,
                                        Controller_Access_Array_Access);
      procedure Free is
        new Ada.Unchecked_Deallocation (Policy'Class,
                                        Policy_Access);

   begin
      --  Release the security controllers.
      if Manager.Permissions /= null then
         for I in Manager.Permissions.all'Range loop
            if Manager.Permissions (I) /= null then
               --  SCz 2011-12-03: GNAT 2011 reports a compilation error:
               --  'missing "with" clause on package "Security.Controllers"'
               --  if we use the 'Security.Controller_Access' type, even if this "with"
               --  clause exist.
               --  gcc 4.4.3 under Ubuntu does not have this issue.
               --  We use the 'Security.Controllers.Controller_Access' type to avoid the compiler
               --  bug but we have to use a temporary variable and do some type conversion...
               declare
                  P : Security.Controllers.Controller_Access := Manager.Permissions (I).all'Access;
               begin
                  Free (P);
                  Manager.Permissions (I) := null;
               end;
            end if;
         end loop;
         Free (Manager.Permissions);
      end if;

      --  Release the policy instances.
      for I in Manager.Policies'Range loop
         exit when Manager.Policies (I) = null;
         Free (Manager.Policies (I));
      end loop;

   end Finalize;

end Security.Policies;

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

with Ada.Unchecked_Deallocation;

with Util.Log.Loggers;
with Util.Serialize.Mappers;
with Util.Serialize.Mappers.Record_Mapper;

with Security.Controllers;
with Security.Contexts;

package body Security.Policies is

   use type Permissions.Permission_Index;

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Security.Policies");

   procedure Free is
     new Ada.Unchecked_Deallocation (Security.Controllers.Controller'Class,
                                     Security.Controllers.Controller_Access);

   --  ------------------------------
   --  Default Security Controllers
   --  ------------------------------
   --  The Auth_Controller grants the permission if there is a principal.
   type Auth_Controller is limited new Security.Controllers.Controller with null record;

   --  Returns true if the user associated with the security context Context was
   --  authentified (ie, it has a principal).
   overriding
   function Has_Permission (Handler    : in Auth_Controller;
                            Context    : in Security.Contexts.Security_Context'Class;
                            Permission : in Security.Permissions.Permission'Class)
                            return Boolean;

   --  The Pass_Through_Controller grants access to anybody.
   type Pass_Through_Controller is limited new Security.Controllers.Controller with null record;

   --  Returns true if the user associated with the security context Context has
   --  the permission to access the URL defined in Permission.
   overriding
   function Has_Permission (Handler    : in Pass_Through_Controller;
                            Context    : in Security.Contexts.Security_Context'Class;
                            Permission : in Security.Permissions.Permission'Class)
                            return Boolean;

   --  ------------------------------
   --  Returns true if the user associated with the security context Context was
   --  authentified (ie, it has a principal).
   --  ------------------------------
   overriding
   function Has_Permission (Handler    : in Auth_Controller;
                            Context    : in Security.Contexts.Security_Context'Class;
                            Permission : in Security.Permissions.Permission'Class)
                            return Boolean is
      pragma Unreferenced (Handler, Permission);
      use type Security.Principal_Access;

      P : constant Security.Principal_Access := Context.Get_User_Principal;
   begin
      if P /= null then
         Log.Debug ("Grant permission because a principal exists");
         return True;
      else
         return False;
      end if;
   end Has_Permission;

   --  ------------------------------
   --  Returns true if the user associated with the security context Context has
   --  the permission to access the URL defined in Permission.
   --  ------------------------------
   overriding
   function Has_Permission (Handler    : in Pass_Through_Controller;
                            Context    : in Security.Contexts.Security_Context'Class;
                            Permission : in Security.Permissions.Permission'Class)
                            return Boolean is
      pragma Unreferenced (Handler, Context, Permission);
   begin
      Log.Debug ("Pass through controller grants the permission");
      return True;
   end Has_Permission;

   --  ------------------------------
   --  Get the policy index.
   --  ------------------------------
   function Get_Policy_Index (From : in Policy'Class) return Policy_Index is
   begin
      return From.Index;
   end Get_Policy_Index;

   --  ------------------------------
   --  Add a permission under the given permission name and associated with the controller.
   --  To verify the permission, the controller will be called.
   --  ------------------------------
   procedure Add_Permission (Manager    : in out Policy;
                             Name       : in String;
                             Permission : in Controller_Access) is
   begin
      Manager.Manager.Add_Permission (Name, Permission);
   end Add_Permission;

   --  ------------------------------
   --  Get the policy with the name Name registered in the policy manager.
   --  Returns null if there is no such policy.
   --  ------------------------------
   function Get_Policy (Manager : in Policy_Manager;
                        Name    : in String) return Policy_Access is
   begin
      for I in Manager.Policies'Range loop
         if Manager.Policies (I) = null then
            return null;
         elsif Manager.Policies (I).Get_Name = Name then
            return Manager.Policies (I);
         end if;
      end loop;
      return null;
   end Get_Policy;

   --  ------------------------------
   --  Add the policy to the policy manager.  After a policy is added in the manager,
   --  it can participate in the security policy.
   --  Raises Policy_Error if the policy table is full.
   --  ------------------------------
   procedure Add_Policy (Manager : in out Policy_Manager;
                         Policy  : in Policy_Access) is
      Name : constant String := Policy.Get_Name;
   begin
      Log.Info ("Adding policy {0}", Name);

      for I in Manager.Policies'Range loop
         if Manager.Policies (I) = null then
            Manager.Policies (I) := Policy;
            Policy.Manager := Manager'Unchecked_Access;
            Policy.Index   := I;
            return;
         end if;
      end loop;
      Log.Error ("Policy table is full, increase policy manager table to {0} to add policy {1}",
                 Policy_Index'Image (Manager.Max_Policies + 1), Name);
      raise Policy_Error;
   end Add_Policy;

   --  ------------------------------
   --  Add a permission under the given permission name and associated with the controller.
   --  To verify the permission, the controller will be called.
   --  ------------------------------
   procedure Add_Permission (Manager    : in out Policy_Manager;
                             Name       : in String;
                             Permission : in Controller_Access) is
      Index : Permission_Index;
   begin
      Log.Info ("Adding permission {0}", Name);

      Permissions.Add_Permission (Name, Index);
      if Index >= Manager.Last_Index then
         declare
            Count : constant Permission_Index := Index + 32;
            Perms : constant Controller_Access_Array_Access
              := new Controller_Access_Array (0 .. Count);
         begin
            if Manager.Permissions /= null then
               Perms (Manager.Permissions'Range) := Manager.Permissions.all;
            end if;
            Manager.Permissions := Perms;
            Manager.Last_Index := Count;
         end;
      end if;

      --  If the permission has a controller, release it.
      if Manager.Permissions (Index) /= null then
         Log.Warn ("Permission {0} is redefined", Name);

         --  SCz 2011-12-03: GNAT 2011 reports a compilation error:
         --  'missing "with" clause on package "Security.Controllers"'
         --  if we use the 'Security.Controller_Access' type, even if this "with"
         --  clause exist.
         --  gcc 4.4.3 under Ubuntu does not have this issue.
         --  We use the 'Security.Controllers.Controller_Access' type to avoid the compiler
         --  bug but we have to use a temporary variable and do some type conversion...
         declare
            P : Security.Controllers.Controller_Access := Manager.Permissions (Index).all'Access;
         begin
            Free (P);
         end;
      end if;

      Manager.Permissions (Index) := Permission;
   end Add_Permission;

   --  ------------------------------
   --  Checks whether the permission defined by the Permission is granted
   --  for the security context passed in Context.
   --  Returns true if such permission is granted.
   --  ------------------------------
   function Has_Permission (Manager    : in Policy_Manager;
                            Context    : in Security.Contexts.Security_Context'Class;
                            Permission : in Security.Permissions.Permission'Class)
                            return Boolean is
   begin
      if Permission.Id >= Manager.Last_Index then
         return False;
      end if;
      declare
         C : constant Controller_Access := Manager.Permissions (Permission.Id);
      begin
         if C = null then
            return False;
         else
            return C.Has_Permission (Context, Permission);
         end if;
      end;
   end Has_Permission;

   --  ------------------------------
   --  Returns True if the security controller is defined for the given permission index.
   --  ------------------------------
   function Has_Controller (Manager : in Policy_Manager;
                            Index   : in Permissions.Permission_Index) return Boolean is
   begin
      return Index < Manager.Last_Index and then Manager.Permissions (Index) /= null;
   end Has_Controller;

   --  ------------------------------
   --  Create the policy contexts to be associated with the security context.
   --  ------------------------------
   function Create_Policy_Contexts (Manager : in Policy_Manager)
                                    return Policy_Context_Array_Access is
   begin
      return new Policy_Context_Array (1 .. Manager.Max_Policies);
   end Create_Policy_Contexts;

   --  ------------------------------
   --  Prepare the XML parser to read the policy configuration.
   --  ------------------------------
   procedure Prepare_Config (Manager : in out Policy_Manager;
                             Reader  : in out Util.Serialize.IO.XML.Parser) is
   begin
      --  Prepare the reader to parse the policy configuration.
      for I in Manager.Policies'Range loop
         exit when Manager.Policies (I) = null;
         Manager.Policies (I).Prepare_Config (Reader);
      end loop;
   end Prepare_Config;

   --  ------------------------------
   --  Finish reading the XML policy configuration.  The security policy implementation can use
   --  this procedure to perform any configuration setup after the configuration is parsed.
   --  ------------------------------
   procedure Finish_Config (Manager : in out Policy_Manager;
                            Reader  : in out Util.Serialize.IO.XML.Parser) is
   begin
      --  Finish the policy configuration.
      for I in Manager.Policies'Range loop
         exit when Manager.Policies (I) = null;
         Manager.Policies (I).Finish_Config (Reader);
      end loop;
   end Finish_Config;

   type Policy_Fields is (FIELD_ALL_PERMISSION, FIELD_AUTH_PERMISSION);

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

   procedure Set_Member (P     : in out Policy_Manager'Class;
                         Field : in Policy_Fields;
                         Value : in Util.Beans.Objects.Object) is
      Name : constant String := Util.Beans.Objects.To_String (Value);
   begin
      case Field is
         when FIELD_ALL_PERMISSION =>
            P.Add_Permission (Name, new Pass_Through_Controller);

         when FIELD_AUTH_PERMISSION =>
            P.Add_Permission (Name, new Auth_Controller);

      end case;
   end Set_Member;

   package Policy_Mapper is
     new Util.Serialize.Mappers.Record_Mapper (Element_Type        => Policy_Manager'Class,
                                               Element_Type_Access => Policy_Manager_Access,
                                               Fields              => Policy_Fields,
                                               Set_Member          => Set_Member);

   Policy_Mapping        : aliased Policy_Mapper.Mapper;

   --  Read the policy file
   procedure Read_Policy (Manager : in out Policy_Manager;
                          File    : in String) is

      use Util;

      Reader : Util.Serialize.IO.XML.Parser;

      package Policy_Config is
        new Reader_Config (Reader, Manager'Unchecked_Access);
      pragma Warnings (Off, Policy_Config);
   begin
      Log.Info ("Reading policy file {0}", File);

      Reader.Add_Mapping ("policy-rules", Policy_Mapping'Access);
      Policy_Mapper.Set_Context (Reader, Manager'Unchecked_Access);
      Manager.Prepare_Config (Reader);

      --  Read the configuration file.
      Reader.Parse (File);

      Manager.Finish_Config (Reader);
   end Read_Policy;

   --  ------------------------------
   --  Initialize the policy manager.
   --  ------------------------------
   overriding
   procedure Initialize (Manager : in out Policy_Manager) is
   begin
      null;
   end Initialize;

   --  ------------------------------
   --  Finalize the policy manager.
   --  ------------------------------
   overriding
   procedure Finalize (Manager : in out Policy_Manager) is
      procedure Free is
        new Ada.Unchecked_Deallocation (Controller_Access_Array,
                                        Controller_Access_Array_Access);
      procedure Free is
        new Ada.Unchecked_Deallocation (Policy'Class,
                                        Policy_Access);

   begin
      --  Release the security controllers.
      if Manager.Permissions /= null then
         for I in Manager.Permissions.all'Range loop
            if Manager.Permissions (I) /= null then
               --  SCz 2011-12-03: GNAT 2011 reports a compilation error:
               --  'missing "with" clause on package "Security.Controllers"'
               --  if we use the 'Security.Controller_Access' type, even if this "with"
               --  clause exist.
               --  gcc 4.4.3 under Ubuntu does not have this issue.
               --  We use the 'Security.Controllers.Controller_Access' type to avoid the compiler
               --  bug but we have to use a temporary variable and do some type conversion...
               declare
                  P : Security.Controllers.Controller_Access := Manager.Permissions (I).all'Access;
               begin
                  Free (P);
                  Manager.Permissions (I) := null;
               end;
            end if;
         end loop;
         Free (Manager.Permissions);
      end if;

      --  Release the policy instances.
      for I in Manager.Policies'Range loop
         exit when Manager.Policies (I) = null;
         Free (Manager.Policies (I));
      end loop;

   end Finalize;

begin
   Policy_Mapping.Add_Mapping ("all-permission/name", FIELD_ALL_PERMISSION);
   Policy_Mapping.Add_Mapping ("auth-permission/name", FIELD_AUTH_PERMISSION);
end Security.Policies;

Add two default security controllers that can be installed to - grant the permission if the security context has a user principal - always grant the permission


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

--  == Text Builders ==
--  The `Util.Texts.Builders` generic package was designed to provide string builders.
--  The interface was designed to reduce memory copies as much as possible.
--
--    * The `Builder` type holds a list of chunks into which texts are appended.
--    * The builder type holds an initial chunk whose capacity is defined when the builder
--      instance is declared.
--    * There is only an `Append` procedure which allows to append text to the builder.
--      This is the only time when a copy is made.
--    * The package defines the `Iterate` operation that allows to get the content
--      collected by the builder.  When using the `Iterate` operation, no copy is
--      performed since chunks data are passed passed by reference.
--    * The type is limited to forbid copies of the builder instance.
--
--  First, instantiate the package for the element type (eg, String):
--
--    package String_Builder is new Util.Texts.Builders (Character, String);
--
--  Declare the string builder instance with its initial capacity:
--
--    Builder : String_Builder.Builder (256);
--
--  And append to it:
--
--    String_Builder.Append (Builder, "Hello");
--
--  To get the content collected in the builder instance, write a procedure that receives
--  the chunk data as parameter:
--
--    procedure Collect (Item : in String) is ...
--
--  And use the `Iterate` operation:
--
--    String_Builder.Iterate (Builder, Collect'Access);
--
private package Wiki.Buffers is

   pragma Preelaborate;

   Chunk_Size : constant := 256;

   type Buffer;
   type Buffer_Access is access all Buffer;

   type Buffer (Len : Positive) is limited record
      Next_Block : Buffer_Access;
      Last       : Natural := 0;
      Content    : Wiki.Strings.WString (1 .. Len);
   end record;

   type Builder (Len : Positive) is new Ada.Finalization.Limited_Controlled with record
      Current    : Buffer_Access;
      Block_Size : Positive := Chunk_Size;
      Length     : Natural  := 0;
      First      : aliased Buffer (Len);
   end record;
   pragma Finalize_Storage_Only (Builder);

   --  Setup the builder.
   overriding
   procedure Initialize (Source : in out Builder);

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

   procedure Next (Content : in out Buffer_Access;
                   Pos     : in out Positive) with Inline_Always;

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

   --  Get the capacity of the builder.
   function Capacity (Source : in Builder) return Natural;

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

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

   --  Append the <tt>New_Item</tt> at the end of the source growing the buffer if necessary.
   procedure Append (Source   : in out Builder;
                     New_Item : in Wiki.Strings.WString);

   --  Append the <tt>New_Item</tt> at the end of the source growing the buffer if necessary.
   procedure Append (Source   : in out Builder;
                     New_Item : in Wiki.Strings.WChar);

   --  Append in `Into` builder the `Content` builder starting at `From` position
   --  and the up to and including the `To` position.
   procedure Append (Into     : in out Builder;
                     Content  : in Builder;
                     From     : in Positive;
                     To       : in Positive);
   procedure Append (Into     : in out Builder;
                     Buffer   : in Buffer_Access;
                     From     : in Positive);

   generic
      with procedure Process (Content : in out Wiki.Strings.WString; Last : out Natural);
   procedure Inline_Append (Source  : in out Builder);

   --  Clear the source freeing any storage allocated for the buffer.
   procedure Clear (Source : in out Builder);

   --  Iterate over the buffer content calling the <tt>Process</tt> procedure with each
   --  chunk.
   procedure Iterate (Source  : in Builder;
                      Process : not null access procedure (Chunk : in Wiki.Strings.WString));

   generic
      with procedure Process (Content : in Wiki.Strings.WString);
   procedure Inline_Iterate (Source  : in Builder);

   generic
      with procedure Process (Content : in out Wiki.Strings.WString);
   procedure Inline_Update (Source : in out Builder);

   --  Get the buffer content as an array.
   function To_Array (Source : in Builder) return Wiki.Strings.WString;

   --  Return the content starting from the tail and up to <tt>Length</tt> items.
   function Tail (Source : in Builder;
                  Length : in Natural) return Wiki.Strings.WString;

   --  Get the element at the given position.
   function Element (Source   : in Builder;
                     Position : in Positive) return Wiki.Strings.WChar;

   --  Find the position of some content by running the `Index` function.
   --  The `Index` function is called with chunks starting at the given position and
   --  until it returns a positive value or we reach the last chunk.  It must return
   --  the found position in the chunk.
--   generic
--      with function Index (Content : in Wiki.Strings.WString) return Natural;
--   function Find (Source   : in Builder;
--                  Position : in Positive) return Natural;

   --  Call the <tt>Process</tt> procedure with the full buffer content, trying to avoid
   --  secondary stack copies as much as possible.
   generic
      with procedure Process (Content : in Wiki.Strings.WString);
   procedure Get (Source : in Builder);

   function Count_Occurence (Buffer : in Buffer_Access;
                             From   : in Positive;
                             Item   : in Wiki.Strings.WChar) return Natural;

   procedure Count_Occurence (Buffer : in out Buffer_Access;
                              From   : in out Positive;
                              Item   : in Wiki.Strings.WChar;
                              Count  : out Natural);

   procedure Find (Buffer : in out Buffer_Access;
                   From   : in out Positive;
                   Item   : in Wiki.Strings.WChar);

   pragma Inline (Length);
   pragma Inline (Iterate);

end Wiki.Buffers;

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

--  == Text Builders ==
--  The `Util.Texts.Builders` generic package was designed to provide string builders.
--  The interface was designed to reduce memory copies as much as possible.
--
--    * The `Builder` type holds a list of chunks into which texts are appended.
--    * The builder type holds an initial chunk whose capacity is defined when the builder
--      instance is declared.
--    * There is only an `Append` procedure which allows to append text to the builder.
--      This is the only time when a copy is made.
--    * The package defines the `Iterate` operation that allows to get the content
--      collected by the builder.  When using the `Iterate` operation, no copy is
--      performed since chunks data are passed passed by reference.
--    * The type is limited to forbid copies of the builder instance.
--
--  First, instantiate the package for the element type (eg, String):
--
--    package String_Builder is new Util.Texts.Builders (Character, String);
--
--  Declare the string builder instance with its initial capacity:
--
--    Builder : String_Builder.Builder (256);
--
--  And append to it:
--
--    String_Builder.Append (Builder, "Hello");
--
--  To get the content collected in the builder instance, write a procedure that receives
--  the chunk data as parameter:
--
--    procedure Collect (Item : in String) is ...
--
--  And use the `Iterate` operation:
--
--    String_Builder.Iterate (Builder, Collect'Access);
--
private package Wiki.Buffers is

   pragma Preelaborate;

   Chunk_Size : constant := 256;

   type Buffer;
   type Buffer_Access is access all Buffer;

   type Buffer (Len : Positive) is limited record
      Next_Block : Buffer_Access;
      Last       : Natural := 0;
      Offset     : Natural := 0;
      Content    : Wiki.Strings.WString (1 .. Len);
   end record;

   type Builder (Len : Positive) is new Ada.Finalization.Limited_Controlled with record
      Current    : Buffer_Access;
      Block_Size : Positive := Chunk_Size;
      Length     : Natural  := 0;
      First      : aliased Buffer (Len);
   end record;
   pragma Finalize_Storage_Only (Builder);

   --  Setup the builder.
   overriding
   procedure Initialize (Source : in out Builder);

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

   --  Move forward to skip a number of items.
   procedure Next (Content : in out Buffer_Access;
                   Pos     : in out Positive) with Inline_Always;

   procedure Next (Content : in out Buffer_Access;
                   Pos     : in out Positive;
                   Count   : in Natural);

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

   --  Get the capacity of the builder.
   function Capacity (Source : in Builder) return Natural;

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

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

   --  Append the <tt>New_Item</tt> at the end of the source growing the buffer if necessary.
   procedure Append (Source   : in out Builder;
                     New_Item : in Wiki.Strings.WString);

   --  Append the <tt>New_Item</tt> at the end of the source growing the buffer if necessary.
   procedure Append (Source   : in out Builder;
                     New_Item : in Wiki.Strings.WChar);

   --  Append in `Into` builder the `Content` builder starting at `From` position
   --  and the up to and including the `To` position.
   procedure Append (Into     : in out Builder;
                     Content  : in Builder;
                     From     : in Positive;
                     To       : in Positive);
   procedure Append (Into     : in out Builder;
                     Buffer   : in Buffer_Access;
                     From     : in Positive);

   generic
      with procedure Process (Content : in out Wiki.Strings.WString; Last : out Natural);
   procedure Inline_Append (Source  : in out Builder);

   --  Clear the source freeing any storage allocated for the buffer.
   procedure Clear (Source : in out Builder);

   --  Iterate over the buffer content calling the <tt>Process</tt> procedure with each
   --  chunk.
   procedure Iterate (Source  : in Builder;
                      Process : not null access procedure (Chunk : in Wiki.Strings.WString));

   generic
      with procedure Process (Content : in Wiki.Strings.WString);
   procedure Inline_Iterate (Source  : in Builder);

   generic
      with procedure Process (Content : in out Wiki.Strings.WString);
   procedure Inline_Update (Source : in out Builder);

   --  Get the buffer content as an array.
   function To_Array (Source : in Builder) return Wiki.Strings.WString;

   --  Return the content starting from the tail and up to <tt>Length</tt> items.
   function Tail (Source : in Builder;
                  Length : in Natural) return Wiki.Strings.WString;

   --  Get the element at the given position.
   function Element (Source   : in Builder;
                     Position : in Positive) return Wiki.Strings.WChar;

   --  Find the position of some content by running the `Index` function.
   --  The `Index` function is called with chunks starting at the given position and
   --  until it returns a positive value or we reach the last chunk.  It must return
   --  the found position in the chunk.
--   generic
--      with function Index (Content : in Wiki.Strings.WString) return Natural;
--   function Find (Source   : in Builder;
--                  Position : in Positive) return Natural;

   --  Call the <tt>Process</tt> procedure with the full buffer content, trying to avoid
   --  secondary stack copies as much as possible.
   generic
      with procedure Process (Content : in Wiki.Strings.WString);
   procedure Get (Source : in Builder);

   function Count_Occurence (Buffer : in Buffer_Access;
                             From   : in Positive;
                             Item   : in Wiki.Strings.WChar) return Natural;

   procedure Count_Occurence (Buffer : in out Buffer_Access;
                              From   : in out Positive;
                              Item   : in Wiki.Strings.WChar;
                              Count  : out Natural);

   procedure Find (Buffer : in out Buffer_Access;
                   From   : in out Positive;
                   Item   : in Wiki.Strings.WChar);

   pragma Inline (Length);
   pragma Inline (Iterate);

end Wiki.Buffers;

Add Next procedure to move forward by several characters


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

with Natools.Smaz_Implementations.Base_64_Tools;

package body Natools.Smaz_Implementations.Base_4096 is

   package Tools renames Natools.Smaz_Implementations.Base_64_Tools;

   use type Ada.Streams.Stream_Element_Offset;

   procedure Read_Code
     (Input : in Ada.Streams.Stream_Element_Array;
      Offset : in out Ada.Streams.Stream_Element_Offset;
      Code : out Base_4096_Digit);
      --  Read two base-64 symbols and assemble them into a base-4096 number

   ------------------------------
   -- Local Helper Subprograms --
   ------------------------------

   procedure Read_Code
     (Input : in Ada.Streams.Stream_Element_Array;
      Offset : in out Ada.Streams.Stream_Element_Offset;
      Code : out Base_4096_Digit)
   is
      Low, High : Tools.Base_64_Digit;
   begin
      Tools.Next_Digit (Input, Offset, Low);
      Tools.Next_Digit (Input, Offset, High);
      Code := Base_4096_Digit (Low) + Base_4096_Digit (High) * 64;
   end Read_Code;

   ----------------------
   -- Public Interface --
   ----------------------

   procedure Read_Code
     (Input : in Ada.Streams.Stream_Element_Array;
      Offset : in out Ada.Streams.Stream_Element_Offset;
      Code : out Base_4096_Digit;
      Verbatim_Length : out Natural;
      Last_Code : in Base_4096_Digit;
      Variable_Length_Verbatim : in Boolean) is
   begin
      Read_Code (Input, Offset, Code);

      if Code <= Last_Code then
         Verbatim_Length := 0;
      elsif not Variable_Length_Verbatim then
         Verbatim_Length := Positive (Base_4096_Digit'Last - Code + 1);
         Code := 0;
      elsif Code < Base_4096_Digit'Last then
         Verbatim_Length := Positive (Base_4096_Digit'Last - Code);
         Code := 0;
      else
         Read_Code (Input, Offset, Code);
         Verbatim_Length
           := Natural (Code) + Natural (Base_4096_Digit'Last - Last_Code);
         Code := 0;
      end if;
   end Read_Code;

   procedure Read_Verbatim
     (Input : in Ada.Streams.Stream_Element_Array;
      Offset : in out Ada.Streams.Stream_Element_Offset;
      Output : out String) is
   begin
      Tools.Decode (Input, Offset, Output);
   end Read_Verbatim;

   procedure Skip_Verbatim
     (Input : in Ada.Streams.Stream_Element_Array;
      Offset : in out Ada.Streams.Stream_Element_Offset;
      Verbatim_Length : in Positive)
   is
      Code : Tools.Base_64_Digit;
   begin
      for I in 1 .. Tools.Image_Length (Verbatim_Length) loop
         Tools.Next_Digit (Input, Offset, Code);
      end loop;
   end Skip_Verbatim;

   function Verbatim_Size
     (Input_Length : in Positive;
      Last_Code : in Base_4096_Digit;
      Variable_Length_Verbatim : in Boolean)
     return Ada.Streams.Stream_Element_Count
   is
      Verbatim1_Max_Size : constant Natural
        := Natural (Base_4096_Digit'Last - Last_Code)
         - Boolean'Pos (Variable_Length_Verbatim);
      Verbatim2_Max_Size : constant Natural
        := Natural (Base_4096_Digit'Last) + Verbatim1_Max_Size + 1;

      Input_Index : Natural := 0;
      Remaining_Length, Block_Length : Positive;
      Result : Ada.Streams.Stream_Element_Count := 0;
   begin
      while Input_Index < Input_Length loop
         Remaining_Length := Input_Length - Input_Index;

         if Variable_Length_Verbatim
           and then Remaining_Length > Verbatim1_Max_Size
         then
            Block_Length := Positive'Min
              (Remaining_Length, Verbatim2_Max_Size);
            Result := Result + 4;
         else
            Block_Length := Positive'Min
              (Remaining_Length, Verbatim1_Max_Size);
            Result := Result + 2;
         end if;

         Result := Result + Tools.Image_Length (Block_Length);
         Input_Index := Input_Index + Block_Length;
      end loop;

      return Result;
   end Verbatim_Size;

   procedure Write_Code
     (Output : in out Ada.Streams.Stream_Element_Array;
      Offset : in out Ada.Streams.Stream_Element_Offset;
      Code : in Base_4096_Digit)
   is
      Low : constant Tools.Base_64_Digit := Tools.Base_64_Digit (Code mod 64);
      High : constant Tools.Base_64_Digit := Tools.Base_64_Digit (Code / 64);
   begin
      Output (Offset + 0) := Tools.Image (Low);
      Output (Offset + 1) := Tools.Image (High);
      Offset := Offset + 2;
   end Write_Code;

   procedure Write_Verbatim
     (Output : in out Ada.Streams.Stream_Element_Array;
      Offset : in out Ada.Streams.Stream_Element_Offset;
      Input : in String;
      Last_Code : in Base_4096_Digit;
      Variable_Length_Verbatim : in Boolean)
   is
      Verbatim1_Max_Size : constant Natural
        := Natural (Base_4096_Digit'Last - Last_Code)
         - Boolean'Pos (Variable_Length_Verbatim);
      Verbatim2_Max_Size : constant Natural
        := Natural (Base_4096_Digit'Last) + Verbatim1_Max_Size + 1;

      Input_Index : Positive := Input'First;
      Remaining_Length, Block_Length : Positive;
   begin
      while Input_Index in Input'Range loop
         Remaining_Length := Input'Last - Input_Index + 1;

         if Variable_Length_Verbatim
           and then Remaining_Length > Verbatim1_Max_Size
         then
            Block_Length := Positive'Min
              (Remaining_Length, Verbatim2_Max_Size);
            Write_Code (Output, Offset, Base_4096_Digit'Last);
            Write_Code (Output, Offset, Base_4096_Digit
              (Block_Length - Verbatim1_Max_Size - 1));
         else
            Block_Length := Positive'Min
              (Remaining_Length, Verbatim1_Max_Size);
            Write_Code (Output, Offset, Base_4096_Digit
              (Base_4096_Digit'Last - Base_4096_Digit (Block_Length)
                  + 1 - Boolean'Pos (Variable_Length_Verbatim)));
         end if;

         Tools.Encode
           (Input (Input_Index .. Input_Index + Block_Length - 1),
            Output, Offset);
         Input_Index := Input_Index + Block_Length;
      end loop;
   end Write_Verbatim;

end Natools.Smaz_Implementations.Base_4096;

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

with Natools.Smaz_Implementations.Base_64_Tools;

package body Natools.Smaz_Implementations.Base_4096 is

   package Tools renames Natools.Smaz_Implementations.Base_64_Tools;

   use type Ada.Streams.Stream_Element_Offset;

   procedure Read_Code
     (Input : in Ada.Streams.Stream_Element_Array;
      Offset : in out Ada.Streams.Stream_Element_Offset;
      Code : out Base_4096_Digit);
   procedure Read_Code_Or_End
     (Input : in Ada.Streams.Stream_Element_Array;
      Offset : in out Ada.Streams.Stream_Element_Offset;
      Code : out Base_4096_Digit;
      Finished : out Boolean);
      --  Read two base-64 symbols and assemble them into a base-4096 number

   ------------------------------
   -- Local Helper Subprograms --
   ------------------------------

   procedure Read_Code
     (Input : in Ada.Streams.Stream_Element_Array;
      Offset : in out Ada.Streams.Stream_Element_Offset;
      Code : out Base_4096_Digit)
   is
      Low, High : Tools.Base_64_Digit;
   begin
      Tools.Next_Digit (Input, Offset, Low);
      Tools.Next_Digit (Input, Offset, High);
      Code := Base_4096_Digit (Low) + Base_4096_Digit (High) * 64;
   end Read_Code;

   procedure Read_Code_Or_End
     (Input : in Ada.Streams.Stream_Element_Array;
      Offset : in out Ada.Streams.Stream_Element_Offset;
      Code : out Base_4096_Digit;
      Finished : out Boolean)
   is
      Low, High : Tools.Base_64_Digit;
   begin
      Tools.Next_Digit_Or_End (Input, Offset, Low, Finished);

      if Finished then
         return;
      end if;

      Tools.Next_Digit (Input, Offset, High);
      Code := Base_4096_Digit (Low) + Base_4096_Digit (High) * 64;
   end Read_Code_Or_End;

   ----------------------
   -- Public Interface --
   ----------------------

   procedure Read_Code
     (Input : in Ada.Streams.Stream_Element_Array;
      Offset : in out Ada.Streams.Stream_Element_Offset;
      Code : out Base_4096_Digit;
      Verbatim_Length : out Natural;
      Last_Code : in Base_4096_Digit;
      Variable_Length_Verbatim : in Boolean)
   is
      Finished : Boolean;
   begin
      Read_Code_Or_End (Input, Offset, Code, Finished);

      if Finished then
         Code := Base_4096_Digit'Last;
         Verbatim_Length := 0;
         return;
      end if;

      if Code <= Last_Code then
         Verbatim_Length := 0;
      elsif not Variable_Length_Verbatim then
         Verbatim_Length := Positive (Base_4096_Digit'Last - Code + 1);
         Code := 0;
      elsif Code < Base_4096_Digit'Last then
         Verbatim_Length := Positive (Base_4096_Digit'Last - Code);
         Code := 0;
      else
         Read_Code (Input, Offset, Code);
         Verbatim_Length
           := Natural (Code) + Natural (Base_4096_Digit'Last - Last_Code);
         Code := 0;
      end if;
   end Read_Code;

   procedure Read_Verbatim
     (Input : in Ada.Streams.Stream_Element_Array;
      Offset : in out Ada.Streams.Stream_Element_Offset;
      Output : out String) is
   begin
      Tools.Decode (Input, Offset, Output);
   end Read_Verbatim;

   procedure Skip_Verbatim
     (Input : in Ada.Streams.Stream_Element_Array;
      Offset : in out Ada.Streams.Stream_Element_Offset;
      Verbatim_Length : in Positive)
   is
      Code : Tools.Base_64_Digit;
   begin
      for I in 1 .. Tools.Image_Length (Verbatim_Length) loop
         Tools.Next_Digit (Input, Offset, Code);
      end loop;
   end Skip_Verbatim;

   function Verbatim_Size
     (Input_Length : in Positive;
      Last_Code : in Base_4096_Digit;
      Variable_Length_Verbatim : in Boolean)
     return Ada.Streams.Stream_Element_Count
   is
      Verbatim1_Max_Size : constant Natural
        := Natural (Base_4096_Digit'Last - Last_Code)
         - Boolean'Pos (Variable_Length_Verbatim);
      Verbatim2_Max_Size : constant Natural
        := Natural (Base_4096_Digit'Last) + Verbatim1_Max_Size + 1;

      Input_Index : Natural := 0;
      Remaining_Length, Block_Length : Positive;
      Result : Ada.Streams.Stream_Element_Count := 0;
   begin
      while Input_Index < Input_Length loop
         Remaining_Length := Input_Length - Input_Index;

         if Variable_Length_Verbatim
           and then Remaining_Length > Verbatim1_Max_Size
         then
            Block_Length := Positive'Min
              (Remaining_Length, Verbatim2_Max_Size);
            Result := Result + 4;
         else
            Block_Length := Positive'Min
              (Remaining_Length, Verbatim1_Max_Size);
            Result := Result + 2;
         end if;

         Result := Result + Tools.Image_Length (Block_Length);
         Input_Index := Input_Index + Block_Length;
      end loop;

      return Result;
   end Verbatim_Size;

   procedure Write_Code
     (Output : in out Ada.Streams.Stream_Element_Array;
      Offset : in out Ada.Streams.Stream_Element_Offset;
      Code : in Base_4096_Digit)
   is
      Low : constant Tools.Base_64_Digit := Tools.Base_64_Digit (Code mod 64);
      High : constant Tools.Base_64_Digit := Tools.Base_64_Digit (Code / 64);
   begin
      Output (Offset + 0) := Tools.Image (Low);
      Output (Offset + 1) := Tools.Image (High);
      Offset := Offset + 2;
   end Write_Code;

   procedure Write_Verbatim
     (Output : in out Ada.Streams.Stream_Element_Array;
      Offset : in out Ada.Streams.Stream_Element_Offset;
      Input : in String;
      Last_Code : in Base_4096_Digit;
      Variable_Length_Verbatim : in Boolean)
   is
      Verbatim1_Max_Size : constant Natural
        := Natural (Base_4096_Digit'Last - Last_Code)
         - Boolean'Pos (Variable_Length_Verbatim);
      Verbatim2_Max_Size : constant Natural
        := Natural (Base_4096_Digit'Last) + Verbatim1_Max_Size + 1;

      Input_Index : Positive := Input'First;
      Remaining_Length, Block_Length : Positive;
   begin
      while Input_Index in Input'Range loop
         Remaining_Length := Input'Last - Input_Index + 1;

         if Variable_Length_Verbatim
           and then Remaining_Length > Verbatim1_Max_Size
         then
            Block_Length := Positive'Min
              (Remaining_Length, Verbatim2_Max_Size);
            Write_Code (Output, Offset, Base_4096_Digit'Last);
            Write_Code (Output, Offset, Base_4096_Digit
              (Block_Length - Verbatim1_Max_Size - 1));
         else
            Block_Length := Positive'Min
              (Remaining_Length, Verbatim1_Max_Size);
            Write_Code (Output, Offset, Base_4096_Digit
              (Base_4096_Digit'Last - Base_4096_Digit (Block_Length)
                  + 1 - Boolean'Pos (Variable_Length_Verbatim)));
         end if;

         Tools.Encode
           (Input (Input_Index .. Input_Index + Block_Length - 1),
            Output, Offset);
         Input_Index := Input_Index + Block_Length;
      end loop;
   end Write_Verbatim;

end Natools.Smaz_Implementations.Base_4096;

check end-of-input in Read_Code

smaz_implementations-base_4096: check end-of-input in Read_Code


-----------------------------------------------------------------------
--  ado-queries-tests -- Test loading of database queries
--  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 Util.Test_Caller;
with Util.Properties;

with ADO.Drivers.Connections;
with ADO.Queries.Loaders;
package body ADO.Queries.Tests is

   use Util.Tests;

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test ADO.Queries.Read_Query",
                       Test_Load_Queries'Access);
      Caller.Add_Test (Suite, "Test ADO.Queries.Initialize",
                       Test_Initialize'Access);
   end Add_Tests;

   package Simple_Query_File is
     new ADO.Queries.Loaders.File (Path => "regtests/files/simple-query.xml",
                                   Sha1 => "");

   package Multi_Query_File is
     new ADO.Queries.Loaders.File (Path => "regtests/files/multi-query.xml",
                                   Sha1 => "");

   package Simple_Query is
     new ADO.Queries.Loaders.Query (Name => "simple-query",
                                    File => Simple_Query_File.File'Access);

   package Simple_Query_2 is
     new ADO.Queries.Loaders.Query (Name => "simple-query",
                                    File => Multi_Query_File.File'Access);

   package Index_Query is
     new ADO.Queries.Loaders.Query (Name => "index",
                                    File => Multi_Query_File.File'Access);

   package Value_Query is
     new ADO.Queries.Loaders.Query (Name => "value",
                                    File => Multi_Query_File.File'Access);

   pragma Warnings (Off, Simple_Query_2);
   pragma Warnings (Off, Value_Query);

   procedure Test_Load_Queries (T : in out Test) is
      use ADO.Drivers.Connections;

      Mysql_Driver  : constant Driver_Access := ADO.Drivers.Connections.Get_Driver ("mysql");
      Props         : constant Util.Properties.Manager := Util.Tests.Get_Properties;
   begin
      --  Configure the XML query loader.
      ADO.Queries.Loaders.Initialize (Props.Get ("ado.queries.paths", ".;db"),
                                      Props.Get ("ado.queries.load", "false") = "true");

      declare
         SQL : constant String := ADO.Queries.Get_SQL (Simple_Query.Query'Access, 0);
      begin
         Assert_Equals (T, "select count(*) from user", SQL, "Invalid query for 'simple-query'");
      end;

      declare
         SQL : constant String := ADO.Queries.Get_SQL (Index_Query.Query'Access, 0);
      begin
         Assert_Equals (T, "select 0", SQL, "Invalid query for 'index'");
      end;

      if Mysql_Driver /= null then
         declare
            SQL : constant String := ADO.Queries.Get_SQL (Index_Query.Query'Access, 1);
         begin
            Assert_Equals (T, "select 1", SQL, "Invalid query for 'index'");
         end;
      end if;
   end Test_Load_Queries;

   --  ------------------------------
   --  Test the Initialize operation called several times
   --  ------------------------------
   procedure Test_Initialize (T : in out Test) is
      use ADO.Drivers.Connections;

      Props : constant Util.Properties.Manager := Util.Tests.Get_Properties;
      Info  : Query_Info_Ref.Ref;
   begin
      --  Configure and load the XML queries.
      ADO.Queries.Loaders.Initialize (Props.Get ("ado.queries.paths", ".;db"), True);
      T.Assert (not Simple_Query.Query.Query.Get.Is_Null, "The simple query was not loaded");
      T.Assert (not Index_Query.Query.Query.Get.Is_Null, "The index query was not loaded");
      Info := Simple_Query.Query.Query.Get;

      --  Re-configure but do not reload.
      ADO.Queries.Loaders.Initialize (Props.Get ("ado.queries.paths", ".;db"), False);
      T.Assert (Info.Value = Simple_Query.Query.Query.Get.Value,
                "The simple query instance was not changed");

      --  Configure again and reload.  The query info must have changed.
      ADO.Queries.Loaders.Initialize (Props.Get ("ado.queries.paths", ".;db"), True);
      T.Assert (Info.Value /= Simple_Query.Query.Query.Get.Value,
                "The simple query instance was not changed");

      --  Due to the reference held by 'Info', it refers to the data loaded first.
      T.Assert (Length (Info.Value.Main_Query (0).SQL) > 0, "The old query is not valid");
   end Test_Initialize;

end ADO.Queries.Tests;

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

with Util.Test_Caller;
with Util.Properties;

with ADO.Drivers.Connections;
with ADO.Queries.Loaders;
package body ADO.Queries.Tests is

   use Util.Tests;

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test ADO.Queries.Read_Query",
                       Test_Load_Queries'Access);
      Caller.Add_Test (Suite, "Test ADO.Queries.Initialize",
                       Test_Initialize'Access);
   end Add_Tests;

   package Simple_Query_File is
     new ADO.Queries.Loaders.File (Path => "regtests/files/simple-query.xml",
                                   Sha1 => "");

   package Multi_Query_File is
     new ADO.Queries.Loaders.File (Path => "regtests/files/multi-query.xml",
                                   Sha1 => "");

   package Simple_Query is
     new ADO.Queries.Loaders.Query (Name => "simple-query",
                                    File => Simple_Query_File.File'Access);

   package Simple_Query_2 is
     new ADO.Queries.Loaders.Query (Name => "simple-query",
                                    File => Multi_Query_File.File'Access);

   package Index_Query is
     new ADO.Queries.Loaders.Query (Name => "index",
                                    File => Multi_Query_File.File'Access);

   package Value_Query is
     new ADO.Queries.Loaders.Query (Name => "value",
                                    File => Multi_Query_File.File'Access);

   pragma Warnings (Off, Simple_Query_2);
   pragma Warnings (Off, Value_Query);

   procedure Test_Load_Queries (T : in out Test) is
      use ADO.Drivers.Connections;

      Mysql_Driver  : constant Driver_Access := ADO.Drivers.Connections.Get_Driver ("mysql");
      Sqlite_Driver : constant Driver_Access := ADO.Drivers.Connections.Get_Driver ("sqlite");
      Props         : constant Util.Properties.Manager := Util.Tests.Get_Properties;
   begin
      --  Configure the XML query loader.
      ADO.Queries.Loaders.Initialize (Props.Get ("ado.queries.paths", ".;db"),
                                      Props.Get ("ado.queries.load", "false") = "true");

      declare
         SQL : constant String := ADO.Queries.Get_SQL (Simple_Query.Query'Access, 0);
      begin
         Assert_Equals (T, "select count(*) from user", SQL, "Invalid query for 'simple-query'");
      end;

      declare
         SQL : constant String := ADO.Queries.Get_SQL (Index_Query.Query'Access, 0);
      begin
         Assert_Equals (T, "select 0", SQL, "Invalid query for 'index'");
      end;

      if Mysql_Driver /= null then
         declare
            SQL : constant String := ADO.Queries.Get_SQL (Index_Query.Query'Access,
                                                          Mysql_Driver.Get_Driver_Index);
         begin
            Assert_Equals (T, "select 1", SQL, "Invalid query for 'index' (MySQL driver)");
         end;
      end if;
      if Sqlite_Driver /= null then
         declare
            SQL : constant String := ADO.Queries.Get_SQL (Index_Query.Query'Access,
                                                          Sqlite_Driver.Get_Driver_Index);
         begin
            Assert_Equals (T, "select 0", SQL, "Invalid query for 'index' (SQLite driver)");
         end;
      end if;
   end Test_Load_Queries;

   --  ------------------------------
   --  Test the Initialize operation called several times
   --  ------------------------------
   procedure Test_Initialize (T : in out Test) is
      use ADO.Drivers.Connections;

      Props : constant Util.Properties.Manager := Util.Tests.Get_Properties;
      Info  : Query_Info_Ref.Ref;
   begin
      --  Configure and load the XML queries.
      ADO.Queries.Loaders.Initialize (Props.Get ("ado.queries.paths", ".;db"), True);
      T.Assert (not Simple_Query.Query.Query.Get.Is_Null, "The simple query was not loaded");
      T.Assert (not Index_Query.Query.Query.Get.Is_Null, "The index query was not loaded");
      Info := Simple_Query.Query.Query.Get;

      --  Re-configure but do not reload.
      ADO.Queries.Loaders.Initialize (Props.Get ("ado.queries.paths", ".;db"), False);
      T.Assert (Info.Value = Simple_Query.Query.Query.Get.Value,
                "The simple query instance was not changed");

      --  Configure again and reload.  The query info must have changed.
      ADO.Queries.Loaders.Initialize (Props.Get ("ado.queries.paths", ".;db"), True);
      T.Assert (Info.Value /= Simple_Query.Query.Query.Get.Value,
                "The simple query instance was not changed");

      --  Due to the reference held by 'Info', it refers to the data loaded first.
      T.Assert (Length (Info.Value.Main_Query (0).SQL) > 0, "The old query is not valid");
   end Test_Initialize;

end ADO.Queries.Tests;

Fix the load query unit test

Fix the load query unit test


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

with Util.Log.Loggers;

with AWA.Services.Contexts;
package body AWA.Events.Dispatchers.Tasks is

   use Util.Log;
   use Ada.Strings.Unbounded;

   Log : constant Loggers.Logger := Loggers.Create ("AWA.Events.Dispatchers.Tasks");

   --  ------------------------------
   --  Start the dispatcher.
   --  ------------------------------
   overriding
   procedure Start (Manager : in out Task_Dispatcher) is
   begin
      if Manager.Queues.Get_Count > 0 then
         Log.Info ("Starting the tasks");

         if Manager.Workers = null then
            Manager.Workers := new Consumer_Array (1 .. Manager.Task_Count);
         end if;

         for I in Manager.Workers'Range loop
            Manager.Workers (I).Start (Manager'Unchecked_Access);
         end loop;
      else
         Log.Info ("No event dispatcher task started (no event queue to poll)");
      end if;
   end Start;

   --  ------------------------------
   --  Stop the dispatcher.
   --  ------------------------------
   overriding
   procedure Stop (Manager : in out Task_Dispatcher) is
      procedure Free is
        new Ada.Unchecked_Deallocation (Object => Consumer_Array,
                                        Name   => Consumer_Array_Access);
   begin
      if Manager.Workers /= null then
         Log.Info ("Stopping the event dispatcher tasks");

         for I in Manager.Workers'Range loop
            if Manager.Workers (I)'Callable then
               Manager.Workers (I).Stop;
            else
               Log.Error ("Event consumer task terminated abnormally");
            end if;
         end loop;
         Free (Manager.Workers);
      end if;
   end Stop;

   procedure Add_Queue (Manager : in out Task_Dispatcher;
                        Queue   : in AWA.Events.Queues.Queue_Ref;
                        Added   : out Boolean) is
   begin
      Log.Info ("Adding queue {0} to the task dispatcher", Queue.Get_Name);

      Manager.Queues.Enqueue (Queue);
      Added := True;
   end Add_Queue;

   function Create_Dispatcher (Service  : in AWA.Events.Services.Event_Manager_Access;
                               Match    : in String;
                               Count    : in Positive;
                               Priority : in Positive) return Dispatcher_Access is
      Result : constant Task_Dispatcher_Access := new Task_Dispatcher;
   begin
      Result.Task_Count := Count;
      Result.Priority   := Priority;
      Result.Match      := To_Unbounded_String (Match);
      Result.Manager    := Service.all'Access;
      return Result.all'Access;
   end Create_Dispatcher;

   task body Consumer is
      Dispatcher : Task_Dispatcher_Access;
      Time       : Duration := 0.01;
      Do_Work    : Boolean := True;
      Context    : AWA.Services.Contexts.Service_Context;
   begin
      Log.Info ("Event consumer is ready");
      select
         accept Start (D : in Task_Dispatcher_Access) do
            Dispatcher := D;
         end Start;
         Log.Info ("Event consumer is started");

         --  Set the service context.
         Context.Set_Context (Application => Dispatcher.Manager.Get_Application.all'Access,
                              Principal   => null);
         while Do_Work loop
            declare
               Nb_Queues : constant Natural := Dispatcher.Queues.Get_Count;
               Queue     : AWA.Events.Queues.Queue_Ref;
               Nb_Events : Natural := 0;
            begin
               --  We can have several tasks that dispatch events from several queues.
               --  Each queue in the list must be given the same polling quota.
               --  Pick a queue and dispatch some pending events.
               --  Put back the queue in the fifo.
               for I in 1 .. Nb_Queues loop
                  Dispatcher.Queues.Dequeue (Queue);
                  begin
                     Dispatcher.Dispatch (Queue, Nb_Events);

                  exception
                     when E : others =>
                        Log.Error ("Exception when dispatching events", E, True);
                  end;
                  Dispatcher.Queues.Enqueue (Queue);
               end loop;

               --  If we processed something, reset the timeout delay and continue polling.
               --  Otherwise, double the sleep time.
               if Nb_Events /= 0 then
                  Time := 0.01;
               else
                  Log.Debug ("Sleeping {0} seconds", Duration'Image (Time));

                  select
                     accept Stop do
                        Do_Work := False;
                     end Stop;
                  or
                     accept Start (D : in Task_Dispatcher_Access) do
                        Dispatcher := D;
                     end Start;
                  or
                     delay Time;
                  end select;

                  if Time < 60.0 then
                     Time := Time * 2.0;
                  end if;
               end if;
            end;
         end loop;
      or
         terminate;
      end select;
   end Consumer;

end AWA.Events.Dispatchers.Tasks;

-----------------------------------------------------------------------
--  awa-events-dispatchers-tasks -- AWA Event Dispatchers
--  Copyright (C) 2012, 2015, 2017, 2019 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.Log.Loggers;

with AWA.Services.Contexts;
package body AWA.Events.Dispatchers.Tasks is

   use Util.Log;
   use Ada.Strings.Unbounded;

   Log : constant Loggers.Logger := Loggers.Create ("AWA.Events.Dispatchers.Tasks");

   --  ------------------------------
   --  Start the dispatcher.
   --  ------------------------------
   overriding
   procedure Start (Manager : in out Task_Dispatcher) is
   begin
      if Manager.Queues.Get_Count > 0 then
         Log.Info ("Starting the tasks");

         if Manager.Workers = null then
            Manager.Workers := new Consumer_Array (1 .. Manager.Task_Count);
         end if;

         for I in Manager.Workers'Range loop
            Manager.Workers (I).Start (Manager'Unchecked_Access);
         end loop;
      else
         Log.Info ("No event dispatcher task started (no event queue to poll)");
      end if;
   end Start;

   --  ------------------------------
   --  Stop the dispatcher.
   --  ------------------------------
   overriding
   procedure Stop (Manager : in out Task_Dispatcher) is
      procedure Free is
        new Ada.Unchecked_Deallocation (Object => Consumer_Array,
                                        Name   => Consumer_Array_Access);
   begin
      if Manager.Workers /= null then
         Log.Info ("Stopping the event dispatcher tasks");

         for I in Manager.Workers'Range loop
            if Manager.Workers (I)'Callable then
               Manager.Workers (I).Stop;
            else
               Log.Error ("Event consumer task terminated abnormally");
            end if;
         end loop;
         Free (Manager.Workers);
      end if;
   end Stop;

   procedure Add_Queue (Manager : in out Task_Dispatcher;
                        Queue   : in AWA.Events.Queues.Queue_Ref;
                        Added   : out Boolean) is
   begin
      Log.Info ("Adding queue {0} to the task dispatcher", Queue.Get_Name);

      Manager.Queues.Enqueue (Queue);
      Added := True;
   end Add_Queue;

   function Create_Dispatcher (Service  : in AWA.Events.Services.Event_Manager_Access;
                               Match    : in String;
                               Count    : in Positive;
                               Priority : in Positive) return Dispatcher_Access is
      Result : constant Task_Dispatcher_Access := new Task_Dispatcher;
   begin
      Result.Task_Count := Count;
      Result.Priority   := Priority;
      Result.Match      := To_Unbounded_String (Match);
      Result.Manager    := Service.all'Access;
      return Result.all'Access;
   end Create_Dispatcher;

   task body Consumer is
      Dispatcher : Task_Dispatcher_Access;
      Time       : Duration := 0.01;
      Do_Work    : Boolean := True;
   begin
      Log.Info ("Event consumer is ready");
      select
         accept Start (D : in Task_Dispatcher_Access) do
            Dispatcher := D;
         end Start;
         Log.Info ("Event consumer is started");

         while Do_Work loop
            declare
               Nb_Queues : constant Natural := Dispatcher.Queues.Get_Count;
               Queue     : AWA.Events.Queues.Queue_Ref;
               Nb_Events : Natural := 0;
               Context   : AWA.Services.Contexts.Service_Context;
            begin
               --  Set the service context.
               Context.Set_Context (Application => Dispatcher.Manager.Get_Application.all'Access,
                                    Principal   => null);

               --  We can have several tasks that dispatch events from several queues.
               --  Each queue in the list must be given the same polling quota.
               --  Pick a queue and dispatch some pending events.
               --  Put back the queue in the fifo.
               for I in 1 .. Nb_Queues loop
                  Dispatcher.Queues.Dequeue (Queue);
                  begin
                     Dispatcher.Dispatch (Queue, Nb_Events);

                  exception
                     when E : others =>
                        Log.Error ("Exception when dispatching events", E, True);
                  end;
                  Dispatcher.Queues.Enqueue (Queue);
               end loop;

               --  If we processed something, reset the timeout delay and continue polling.
               --  Otherwise, double the sleep time.
               if Nb_Events /= 0 then
                  Time := 0.01;
               else
                  Log.Debug ("Sleeping {0} seconds", Duration'Image (Time));

                  select
                     accept Stop do
                        Do_Work := False;
                     end Stop;
                  or
                     accept Start (D : in Task_Dispatcher_Access) do
                        Dispatcher := D;
                     end Start;
                  or
                     delay Time;
                  end select;

                  if Time < 60.0 then
                     Time := Time * 2.0;
                  end if;
               end if;
            end;
         end loop;
      or
         terminate;
      end select;
   end Consumer;

end AWA.Events.Dispatchers.Tasks;

Create the Service_Context instance for the lifetime of the event dispatching and not for the lifetime of the task


-----------------------------------------------------------------------
--  druss-commands-devices -- Print information about the devices
--  Copyright (C) 2017 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Util.Properties;
with Bbox.API;
with Druss.Gateways;
with Ada.Strings.Unbounded;
package body Druss.Commands.Ping is

   use Ada.Strings.Unbounded;

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

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

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

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

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

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

      procedure Box_Status (Gateway : in out Druss.Gateways.Gateway_Type) is
         procedure Print_Device (Manager : in Util.Properties.Manager;
                                 Name    : in String);

         procedure Print_Device (Manager : in Util.Properties.Manager;
                                 Name    : in String) is
            Link : constant String := Manager.Get (Name & ".link", "");
            Kind : constant String := Manager.Get (Name & ".devicetype", "");
         begin
            if Manager.Get (Name & ".active", "") = "0" then
               return;
            end if;
            Console.Start_Row;
            Console.Print_Field (F_BBOX_IP_ADDR, Gateway.Ip);
            Console.Print_Field (F_IP_ADDR, Manager.Get (Name & ".ipaddress", ""));
            Console.Print_Field (F_HOSTNAME, Manager.Get (Name & ".hostname", ""));
            Console.Print_Field (F_ACTIVE, Manager.Get (Name & ".ping.average", ""));
            if Link = "Ethernet" then
               Console.Print_Field (F_LINK, Link & " port "
                                    & Manager.Get (Name & ".ethernet.logicalport", ""));
            else
               Console.Print_Field (F_LINK, Link & " RSSI "
                                    & Manager.Get (Name & ".wireless.rssi0", ""));
            end if;
            Console.End_Row;
         end Print_Device;

      begin
         Gateway.Refresh;

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

   begin
      Druss.Gateways.Iterate (Context.Gateways, Gateways.ITER_ENABLE, Do_Ping'Access);
      delay 5.0;
      Console.Start_Title;
      Console.Print_Title (F_BBOX_IP_ADDR, "Bbox IP", 16);
      Console.Print_Title (F_IP_ADDR, "Device IP", 16);
      Console.Print_Title (F_HOSTNAME, "Hostname", 28);
      Console.Print_Title (F_ACTIVE, "Ping", 8);
      Console.Print_Title (F_LINK, "Link", 18);
      Console.End_Title;
      Druss.Gateways.Iterate (Context.Gateways, Gateways.ITER_ENABLE, Box_Status'Access);
   end Do_Ping;

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

   --  ------------------------------
   --  Write the help associated with the command.
   --  ------------------------------
   overriding
   procedure Help (Command   : in Command_Type;
                   Context   : in out Context_Type) is
      pragma Unreferenced (Command);
      Console : constant Druss.Commands.Consoles.Console_Access := Context.Console;
   begin
      Console.Notice (N_HELP, "ping: Ask the Bbox to ping the devices");
      Console.Notice (N_HELP, "Usage: ping {active | inactive}");
      Console.Notice (N_HELP, "");
      Console.Notice (N_HELP, "  active     Ping the active devices only");
      Console.Notice (N_HELP, "  inative    Ping the inactive devices only");
   end Help;

end Druss.Commands.Ping;

-----------------------------------------------------------------------
--  druss-commands-devices -- Print information about the devices
--  Copyright (C) 2017 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Util.Properties;
with Bbox.API;
with Druss.Gateways;
with Ada.Strings.Unbounded;
package body Druss.Commands.Ping is

   use Ada.Strings.Unbounded;

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

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

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

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

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

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

      procedure Box_Status (Gateway : in out Druss.Gateways.Gateway_Type) is
         procedure Print_Device (Manager : in Util.Properties.Manager;
                                 Name    : in String);

         procedure Print_Device (Manager : in Util.Properties.Manager;
                                 Name    : in String) is
            Link : constant String := Manager.Get (Name & ".link", "");
            Kind : constant String := Manager.Get (Name & ".devicetype", "");
         begin
            if Manager.Get (Name & ".active", "") = "0" then
               return;
            end if;
            Console.Start_Row;
            Console.Print_Field (F_BBOX_IP_ADDR, Gateway.Ip);
            Console.Print_Field (F_IP_ADDR, Manager.Get (Name & ".ipaddress", ""));
            Console.Print_Field (F_HOSTNAME, Manager.Get (Name & ".hostname", ""));
            Print_Perf (Console, F_ACTIVE, Manager.Get (Name & ".ping.average", ""));
            if Link = "Ethernet" then
               Console.Print_Field (F_LINK, Link & " port "
                                    & Manager.Get (Name & ".ethernet.logicalport", ""));
            else
               Console.Print_Field (F_LINK, Link & " RSSI "
                                    & Manager.Get (Name & ".wireless.rssi0", ""));
            end if;
            Console.End_Row;
         end Print_Device;

      begin
         Gateway.Refresh;

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

   begin
      Druss.Gateways.Iterate (Context.Gateways, Gateways.ITER_ENABLE, Do_Ping'Access);
      delay 5.0;
      Console.Start_Title;
      Console.Print_Title (F_BBOX_IP_ADDR, "Bbox IP", 16);
      Console.Print_Title (F_IP_ADDR, "Device IP", 16);
      Console.Print_Title (F_HOSTNAME, "Hostname", 28);
      Console.Print_Title (F_ACTIVE, "Ping", 15);
      Console.Print_Title (F_LINK, "Link", 18);
      Console.End_Title;
      Druss.Gateways.Iterate (Context.Gateways, Gateways.ITER_ENABLE, Box_Status'Access);
   end Do_Ping;

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

   --  ------------------------------
   --  Write the help associated with the command.
   --  ------------------------------
   overriding
   procedure Help (Command   : in Command_Type;
                   Context   : in out Context_Type) is
      pragma Unreferenced (Command);
      Console : constant Druss.Commands.Consoles.Console_Access := Context.Console;
   begin
      Console.Notice (N_HELP, "ping: Ask the Bbox to ping the devices");
      Console.Notice (N_HELP, "Usage: ping {active | inactive}");
      Console.Notice (N_HELP, "");
      Console.Notice (N_HELP, "  active     Ping the active devices only");
      Console.Notice (N_HELP, "  inative    Ping the inactive devices only");
   end Help;

end Druss.Commands.Ping;

Use the Print_Perf operation to report the ping performance


-----------------------------------------------------------------------
--  html-pages -- HTML Page Components
--  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 Util.Strings;
with ASF.Utils;

--  The <b>Pages</b> package implements various components used when building an HTML page.
--
package body ASF.Components.Html.Pages is

   BODY_ATTRIBUTE_NAMES  : Util.Strings.String_Set.Set;

   HEAD_ATTRIBUTE_NAMES  : Util.Strings.String_Set.Set;

   --  ------------------------------
   --  Head Component
   --  ------------------------------

   --  ------------------------------
   --  Encode the HTML head element.
   --  ------------------------------
   overriding
   procedure Encode_Begin (UI      : in UIHead;
                           Context : in out Contexts.Faces.Faces_Context'Class) is
      Writer : constant Response_Writer_Access := Context.Get_Response_Writer;
   begin
      Writer.Start_Element ("head");
      UI.Render_Attributes (Context, HEAD_ATTRIBUTE_NAMES, Writer);
   end Encode_Begin;

   --  ------------------------------
   --  Terminate the HTML head element.  Before closing the head, generate the resource
   --  links that have been queued for the head generation.
   --  ------------------------------
   overriding
   procedure Encode_End (UI      : in UIHead;
                         Context : in out Contexts.Faces.Faces_Context'Class) is
      pragma Unreferenced (UI);

      Writer : constant Response_Writer_Access := Context.Get_Response_Writer;
   begin
      Writer.Write_Scripts;
      Writer.End_Element ("head");
   end Encode_End;

   --  ------------------------------
   --  Encode the HTML body element.
   --  ------------------------------
   overriding
   procedure Encode_Begin (UI      : in UIBody;
                           Context : in out Contexts.Faces.Faces_Context'Class) is
      Writer : constant Response_Writer_Access := Context.Get_Response_Writer;
   begin
      Writer.Start_Element ("body");
      UI.Render_Attributes (Context, BODY_ATTRIBUTE_NAMES, Writer);
   end Encode_Begin;

   --  ------------------------------
   --  Terminate the HTML body element.  Before closing the body, generate the inclusion
   --  of differed resources (pending javascript, inclusion of javascript files)
   --  ------------------------------
   overriding
   procedure Encode_End (UI      : in UIBody;
                         Context : in out Contexts.Faces.Faces_Context'Class) is
      pragma Unreferenced (UI);

      Writer : constant Response_Writer_Access := Context.Get_Response_Writer;
   begin
      Writer.Write_Scripts;
      Writer.End_Element ("body");
   end Encode_End;

begin
   Utils.Set_Head_Attributes (HEAD_ATTRIBUTE_NAMES);
   Utils.Set_Text_Attributes (BODY_ATTRIBUTE_NAMES);
   Utils.Set_Body_Attributes (BODY_ATTRIBUTE_NAMES);
end ASF.Components.Html.Pages;

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

with Util.Strings;
with Util.Beans.Objects;

with ASF.Utils;

--  The <b>Pages</b> package implements various components used when building an HTML page.
--
package body ASF.Components.Html.Pages is

   BODY_ATTRIBUTE_NAMES  : Util.Strings.String_Set.Set;

   HEAD_ATTRIBUTE_NAMES  : Util.Strings.String_Set.Set;

   --  ------------------------------
   --  Head Component
   --  ------------------------------

   --  ------------------------------
   --  Encode the HTML head element.
   --  ------------------------------
   overriding
   procedure Encode_Begin (UI      : in UIHead;
                           Context : in out Contexts.Faces.Faces_Context'Class) is
      Writer : constant Response_Writer_Access := Context.Get_Response_Writer;
   begin
      Writer.Start_Element ("head");
      UI.Render_Attributes (Context, HEAD_ATTRIBUTE_NAMES, Writer);
   end Encode_Begin;

   --  ------------------------------
   --  Terminate the HTML head element.  Before closing the head, generate the resource
   --  links that have been queued for the head generation.
   --  ------------------------------
   overriding
   procedure Encode_End (UI      : in UIHead;
                         Context : in out Contexts.Faces.Faces_Context'Class) is
      pragma Unreferenced (UI);

      Writer : constant Response_Writer_Access := Context.Get_Response_Writer;
   begin
      Writer.Write_Scripts;
      Writer.End_Element ("head");
   end Encode_End;

   --  ------------------------------
   --  Encode the HTML body element.
   --  ------------------------------
   overriding
   procedure Encode_Begin (UI      : in UIBody;
                           Context : in out Contexts.Faces.Faces_Context'Class) is
      Writer : constant Response_Writer_Access := Context.Get_Response_Writer;
   begin
      Writer.Start_Element ("body");
      UI.Render_Attributes (Context, BODY_ATTRIBUTE_NAMES, Writer);
   end Encode_Begin;

   --  ------------------------------
   --  Terminate the HTML body element.  Before closing the body, generate the inclusion
   --  of differed resources (pending javascript, inclusion of javascript files)
   --  ------------------------------
   overriding
   procedure Encode_End (UI      : in UIBody;
                         Context : in out Contexts.Faces.Faces_Context'Class) is
      pragma Unreferenced (UI);

      Writer : constant Response_Writer_Access := Context.Get_Response_Writer;
   begin
      Writer.Write_Scripts;
      Writer.End_Element ("body");
   end Encode_End;

   --  ------------------------------
   --  Encode the DOCTYPE element.
   --  ------------------------------
   overriding
   procedure Encode_Begin (UI      : in UIDoctype;
                           Context : in out Contexts.Faces.Faces_Context'Class) is
      Writer : constant Response_Writer_Access := Context.Get_Response_Writer;
   begin
      if UI.Is_Rendered (Context) then
         Writer.Write ("<!DOCTYPE ");
         Writer.Write (UI.Get_Attribute ("rootElement", Context, ""));
         declare
            Public : constant Util.Beans.Objects.Object := UI.Get_Attribute (Context, "public");
            System : constant Util.Beans.Objects.Object := UI.Get_Attribute (Context, "system");
         begin
            if not Util.Beans.Objects.Is_Null (Public) then
               Writer.Write (" PUBLIC """);
               Writer.Write (Public);
               Writer.Write ('"');
            end if;
            if not Util.Beans.Objects.Is_Null (System) then
               Writer.Write (" """);
               Writer.Write (System);
               Writer.Write ('"');
            end if;
         end;
         Writer.Write ('>');
      end if;
   end Encode_Begin;

begin
   Utils.Set_Head_Attributes (HEAD_ATTRIBUTE_NAMES);
   Utils.Set_Text_Attributes (BODY_ATTRIBUTE_NAMES);
   Utils.Set_Body_Attributes (BODY_ATTRIBUTE_NAMES);
end ASF.Components.Html.Pages;

Implement the UIDoctype component with the <!DOCTYPE> generation according to the <h:doctype> JSF 2.2 standard