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

with Util.Log.Loggers;
with Util.Systems.DLLs;

with System;
with Ada.Strings.Fixed;
with Ada.Containers.Doubly_Linked_Lists;
with Ada.Exceptions;

package body ADO.Drivers.Connections is

   use Ada.Strings.Fixed;

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("ADO.Drivers.Connections");

   --  Load the database driver.
   procedure Load_Driver (Name : in String);

   --  ------------------------------
   --  Set the connection URL to connect to the database.
   --  The driver connection is a string of the form:
   --
   --   driver://[host][:port]/[database][?property1][=value1]...
   --
   --  If the string is invalid or if the driver cannot be found,
   --  the Connection_Error exception is raised.
   --  ------------------------------
   procedure Set_Connection (Controller : in out Configuration;
                             URI        : in String) is

      Pos, Pos2, Slash_Pos, Next : Natural;
   begin
      Log.Info ("Set connection URI: {0}", URI);

      Controller.URI := To_Unbounded_String (URI);
      Pos := Index (URI, "://");
      if Pos <= 1 then
         Log.Error ("Invalid connection URI: {0}", URI);
         raise Connection_Error
           with "Invalid URI: '" & URI & "'";
      end if;
      Controller.Driver := Get_Driver (URI (URI'First .. Pos - 1));
      if Controller.Driver = null then
         Log.Error ("No driver found for connection URI: {0}", URI);
         raise Connection_Error
           with "Driver '" & URI (URI'First .. Pos - 1) & "' not found";
      end if;

      Pos := Pos + 3;
      Slash_Pos := Index (URI, "/", Pos);
      if Slash_Pos < Pos then
         Log.Error ("Invalid connection URI: {0}", URI);
         raise Connection_Error
           with "Invalid connection URI: '" & URI & "'";
      end if;

      --  Extract the server and port.
      Pos2 := Index (URI, ":", Pos);
      if Pos2 >= Pos then
         Controller.Server := To_Unbounded_String (URI (Pos .. Pos2 - 1));
         begin
            Controller.Port := Integer'Value (URI (Pos2 + 1 .. Slash_Pos - 1));

         exception
            when Constraint_Error =>
               Log.Error ("Invalid port in connection URI: {0}", URI);
               raise Connection_Error
                 with "Invalid port in connection URI: '" & URI & "'";
         end;
      else
         Controller.Port := 0;
         Controller.Server := To_Unbounded_String (URI (Pos .. Slash_Pos - 1));
      end if;

      --  Extract the database name.
      Pos := Index (URI, "?", Slash_Pos);
      if Pos - 1 > Slash_Pos + 1 then
         Controller.Database := To_Unbounded_String (URI (Slash_Pos + 1 .. Pos - 1));
      elsif Pos = 0 and Slash_Pos + 1 < URI'Last then
         Controller.Database := To_Unbounded_String (URI (Slash_Pos + 1 .. URI'Last));
      else
         Controller.Database := Null_Unbounded_String;
      end if;

      --  Parse the optional properties
      if Pos > Slash_Pos then
         while Pos < URI'Last loop
            Pos2 := Index (URI, "=", Pos + 1);
            if Pos2 > Pos then
               Next := Index (URI, "&", Pos2 + 1);
               if Next > 0 then
                  Controller.Properties.Set (URI (Pos + 1 .. Pos2 - 1),
                                             URI (Pos2 + 1 .. Next - 1));
                  Pos := Next;
               else
                  Controller.Properties.Set (URI (Pos + 1 .. Pos2 - 1),
                                             URI (Pos2 + 1 .. URI'Last));
                  Pos := URI'Last;
               end if;
            else
               Controller.Properties.Set (URI (Pos + 1 .. URI'Last), "");
               Pos := URI'Last;
            end if;
         end loop;
      end if;
   end Set_Connection;

   --  ------------------------------
   --  Set a property on the datasource for the driver.
   --  The driver can retrieve the property to configure and open
   --  the database connection.
   --  ------------------------------
   procedure Set_Property (Controller : in out Configuration;
                           Name       : in String;
                           Value      : in String) is
   begin
      Controller.Properties.Set (Name, Value);
   end Set_Property;

   --  ------------------------------
   --  Get a property from the datasource configuration.
   --  If the property does not exist, an empty string is returned.
   --  ------------------------------
   function Get_Property (Controller : in Configuration;
                          Name       : in String) return String is
   begin
      return Controller.Properties.Get (Name, "");
   end Get_Property;

   --  ------------------------------
   --  Get the server hostname.
   --  ------------------------------
   function Get_Server (Controller : in Configuration) return String is
   begin
      return To_String (Controller.Server);
   end Get_Server;

   --  ------------------------------
   --  Set the server hostname.
   --  ------------------------------
   procedure Set_Server (Controller : in out Configuration;
                         Server     : in String) is
   begin
      Controller.Server := To_Unbounded_String (Server);
   end Set_Server;

   --  ------------------------------
   --  Get the server port.
   --  ------------------------------
   function Get_Port (Controller : in Configuration) return Integer is
   begin
      return Controller.Port;
   end Get_Port;

   --  ------------------------------
   --  Get the database name.
   --  ------------------------------
   function Get_Database (Controller : in Configuration) return String is
   begin
      return To_String (Controller.Database);
   end Get_Database;

   --  ------------------------------
   --  Create a new connection using the configuration parameters.
   --  ------------------------------
   procedure Create_Connection (Config : in Configuration'Class;
                                Result : out Database_Connection_Access) is
   begin
      if Config.Driver = null then
         Log.Error ("No driver found for connection {0}", To_String (Config.URI));
         raise Connection_Error with "Data source is not initialized: driver not found";
      end if;
      Config.Driver.Create_Connection (Config, Result);
      Log.Info ("Created connection to '{0}' -> {1}", Config.URI, Result.Ident);

   exception
      when others =>
         Log.Info ("Failed to create connection to '{0}'", Config.URI);
         raise;

   end Create_Connection;

   package Driver_List is
     new Ada.Containers.Doubly_Linked_Lists (Element_Type => Driver_Access);

   Next_Index : Driver_Index := 1;
   Drivers    : Driver_List.List;

   --  ------------------------------
   --  Get the driver unique index.
   --  ------------------------------
   function Get_Driver_Index (D : in Driver) return Driver_Index is
   begin
      return D.Index;
   end Get_Driver_Index;

   --  ------------------------------
   --  Get the driver name.
   --  ------------------------------
   function Get_Driver_Name (D : in Driver) return String is
   begin
      return D.Name.all;
   end Get_Driver_Name;

   --  ------------------------------
   --  Register a database driver.
   --  ------------------------------
   procedure Register (Driver : in Driver_Access) is
   begin
      Log.Info ("Register driver {0}", Driver.Name.all);

      Driver_List.Prepend (Container => Drivers, New_Item => Driver);
      Driver.Index := Next_Index;
      Next_Index := Next_Index + 1;
   end Register;

   --  ------------------------------
   --  Load the database driver.
   --  ------------------------------
   procedure Load_Driver (Name : in String) is
      Lib    : constant String := "libada_ado_" & Name & Util.Systems.DLLs.Extension;
      Symbol : constant String := "ado__drivers__connections__" & Name & "__initialize";
      Handle : Util.Systems.DLLs.Handle;
      Addr   : System.Address;

   begin
      Log.Info ("Loading driver {0}", Lib);
      Handle := Util.Systems.DLLs.Load (Lib);
      Addr := Util.Systems.DLLs.Get_Symbol (Handle, Symbol);

      declare
         procedure Init;
         pragma Import (C, Init);
         for Init'Address use Addr;
      begin
         Init;
      end;
   exception
      when Util.Systems.DLLs.Not_Found =>
         Log.Error ("Driver for {0} was loaded but does not define the initialization symbol",
                    Name);

      when E : Util.Systems.DLLs.Load_Error =>
         Log.Error ("Driver for {0} was not found: {1}",
                    Name, Ada.Exceptions.Exception_Message (E));

   end Load_Driver;

   --  ------------------------------
   --  Get a database driver given its name.
   --  ------------------------------
   function Get_Driver (Name : in String) return Driver_Access is
   begin
      Log.Info ("Get driver {0}", Name);

      for Retry in 0 .. 1 loop
         if Retry > 0 then
            Load_Driver (Name);
         end if;
         declare
            Iter : Driver_List.Cursor := Driver_List.First (Drivers);
         begin
            while Driver_List.Has_Element (Iter) loop
               declare
                  D : constant Driver_Access := Driver_List.Element (Iter);
               begin
                  if Name = D.Name.all then
                     return D;
                  end if;
               end;
               Driver_List.Next (Iter);
            end loop;
         end;
      end loop;
      return null;
   end Get_Driver;

end ADO.Drivers.Connections;

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

with Util.Log.Loggers;
with Util.Systems.DLLs;

with System;
with Ada.Strings.Fixed;
with Ada.Containers.Doubly_Linked_Lists;
with Ada.Exceptions;

package body ADO.Drivers.Connections is

   use Ada.Strings.Fixed;

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("ADO.Drivers.Connections");

   --  Load the database driver.
   procedure Load_Driver (Name : in String);

   --  ------------------------------
   --  Set the connection URL to connect to the database.
   --  The driver connection is a string of the form:
   --
   --   driver://[host][:port]/[database][?property1][=value1]...
   --
   --  If the string is invalid or if the driver cannot be found,
   --  the Connection_Error exception is raised.
   --  ------------------------------
   procedure Set_Connection (Controller : in out Configuration;
                             URI        : in String) is

      Pos, Pos2, Slash_Pos, Next : Natural;
   begin
      Log.Info ("Set connection URI: {0}", URI);

      Controller.URI := To_Unbounded_String (URI);
      Pos := Index (URI, "://");
      if Pos <= 1 then
         Log.Error ("Invalid connection URI: {0}", URI);
         raise Connection_Error
           with "Invalid URI: '" & URI & "'";
      end if;
      Controller.Driver := Get_Driver (URI (URI'First .. Pos - 1));
      if Controller.Driver = null then
         Log.Error ("No driver found for connection URI: {0}", URI);
         raise Connection_Error
           with "Driver '" & URI (URI'First .. Pos - 1) & "' not found";
      end if;

      Pos := Pos + 3;
      Slash_Pos := Index (URI, "/", Pos);
      if Slash_Pos < Pos then
         Log.Error ("Invalid connection URI: {0}", URI);
         raise Connection_Error
           with "Invalid connection URI: '" & URI & "'";
      end if;

      --  Extract the server and port.
      Pos2 := Index (URI, ":", Pos);
      if Pos2 >= Pos then
         Controller.Server := To_Unbounded_String (URI (Pos .. Pos2 - 1));
         begin
            Controller.Port := Natural'Value (URI (Pos2 + 1 .. Slash_Pos - 1));

         exception
            when Constraint_Error =>
               Log.Error ("Invalid port in connection URI: {0}", URI);
               raise Connection_Error
                 with "Invalid port in connection URI: '" & URI & "'";
         end;
      else
         Controller.Port := 0;
         Controller.Server := To_Unbounded_String (URI (Pos .. Slash_Pos - 1));
      end if;

      --  Extract the database name.
      Pos := Index (URI, "?", Slash_Pos);
      if Pos - 1 > Slash_Pos + 1 then
         Controller.Database := To_Unbounded_String (URI (Slash_Pos + 1 .. Pos - 1));
      elsif Pos = 0 and Slash_Pos + 1 < URI'Last then
         Controller.Database := To_Unbounded_String (URI (Slash_Pos + 1 .. URI'Last));
      else
         Controller.Database := Null_Unbounded_String;
      end if;

      --  Parse the optional properties
      if Pos > Slash_Pos then
         while Pos < URI'Last loop
            Pos2 := Index (URI, "=", Pos + 1);
            if Pos2 > Pos then
               Next := Index (URI, "&", Pos2 + 1);
               if Next > 0 then
                  Controller.Properties.Set (URI (Pos + 1 .. Pos2 - 1),
                                             URI (Pos2 + 1 .. Next - 1));
                  Pos := Next;
               else
                  Controller.Properties.Set (URI (Pos + 1 .. Pos2 - 1),
                                             URI (Pos2 + 1 .. URI'Last));
                  Pos := URI'Last;
               end if;
            else
               Controller.Properties.Set (URI (Pos + 1 .. URI'Last), "");
               Pos := URI'Last;
            end if;
         end loop;
      end if;
   end Set_Connection;

   --  ------------------------------
   --  Set a property on the datasource for the driver.
   --  The driver can retrieve the property to configure and open
   --  the database connection.
   --  ------------------------------
   procedure Set_Property (Controller : in out Configuration;
                           Name       : in String;
                           Value      : in String) is
   begin
      Controller.Properties.Set (Name, Value);
   end Set_Property;

   --  ------------------------------
   --  Get a property from the datasource configuration.
   --  If the property does not exist, an empty string is returned.
   --  ------------------------------
   function Get_Property (Controller : in Configuration;
                          Name       : in String) return String is
   begin
      return Controller.Properties.Get (Name, "");
   end Get_Property;

   --  ------------------------------
   --  Get the server hostname.
   --  ------------------------------
   function Get_Server (Controller : in Configuration) return String is
   begin
      return To_String (Controller.Server);
   end Get_Server;

   --  ------------------------------
   --  Set the server hostname.
   --  ------------------------------
   procedure Set_Server (Controller : in out Configuration;
                         Server     : in String) is
   begin
      Controller.Server := To_Unbounded_String (Server);
   end Set_Server;

   --  ------------------------------
   --  Set the server port.
   --  ------------------------------
   procedure Set_Port (Controller : in out Configuration;
                       Port       : in Natural) is
   begin
      Controller.Port := Port;
   end Set_Port;

   --  ------------------------------
   --  Get the server port.
   --  ------------------------------
   function Get_Port (Controller : in Configuration) return Natural is
   begin
      return Controller.Port;
   end Get_Port;

   --  ------------------------------
   --  Get the database name.
   --  ------------------------------
   function Get_Database (Controller : in Configuration) return String is
   begin
      return To_String (Controller.Database);
   end Get_Database;

   --  ------------------------------
   --  Create a new connection using the configuration parameters.
   --  ------------------------------
   procedure Create_Connection (Config : in Configuration'Class;
                                Result : out Database_Connection_Access) is
   begin
      if Config.Driver = null then
         Log.Error ("No driver found for connection {0}", To_String (Config.URI));
         raise Connection_Error with "Data source is not initialized: driver not found";
      end if;
      Config.Driver.Create_Connection (Config, Result);
      Log.Info ("Created connection to '{0}' -> {1}", Config.URI, Result.Ident);

   exception
      when others =>
         Log.Info ("Failed to create connection to '{0}'", Config.URI);
         raise;

   end Create_Connection;

   package Driver_List is
     new Ada.Containers.Doubly_Linked_Lists (Element_Type => Driver_Access);

   Next_Index : Driver_Index := 1;
   Drivers    : Driver_List.List;

   --  ------------------------------
   --  Get the driver unique index.
   --  ------------------------------
   function Get_Driver_Index (D : in Driver) return Driver_Index is
   begin
      return D.Index;
   end Get_Driver_Index;

   --  ------------------------------
   --  Get the driver name.
   --  ------------------------------
   function Get_Driver_Name (D : in Driver) return String is
   begin
      return D.Name.all;
   end Get_Driver_Name;

   --  ------------------------------
   --  Register a database driver.
   --  ------------------------------
   procedure Register (Driver : in Driver_Access) is
   begin
      Log.Info ("Register driver {0}", Driver.Name.all);

      Driver_List.Prepend (Container => Drivers, New_Item => Driver);
      Driver.Index := Next_Index;
      Next_Index := Next_Index + 1;
   end Register;

   --  ------------------------------
   --  Load the database driver.
   --  ------------------------------
   procedure Load_Driver (Name : in String) is
      Lib    : constant String := "libada_ado_" & Name & Util.Systems.DLLs.Extension;
      Symbol : constant String := "ado__drivers__connections__" & Name & "__initialize";
      Handle : Util.Systems.DLLs.Handle;
      Addr   : System.Address;

   begin
      Log.Info ("Loading driver {0}", Lib);
      Handle := Util.Systems.DLLs.Load (Lib);
      Addr := Util.Systems.DLLs.Get_Symbol (Handle, Symbol);

      declare
         procedure Init;
         pragma Import (C, Init);
         for Init'Address use Addr;
      begin
         Init;
      end;
   exception
      when Util.Systems.DLLs.Not_Found =>
         Log.Error ("Driver for {0} was loaded but does not define the initialization symbol",
                    Name);

      when E : Util.Systems.DLLs.Load_Error =>
         Log.Error ("Driver for {0} was not found: {1}",
                    Name, Ada.Exceptions.Exception_Message (E));

   end Load_Driver;

   --  ------------------------------
   --  Get a database driver given its name.
   --  ------------------------------
   function Get_Driver (Name : in String) return Driver_Access is
   begin
      Log.Info ("Get driver {0}", Name);

      for Retry in 0 .. 1 loop
         if Retry > 0 then
            Load_Driver (Name);
         end if;
         declare
            Iter : Driver_List.Cursor := Driver_List.First (Drivers);
         begin
            while Driver_List.Has_Element (Iter) loop
               declare
                  D : constant Driver_Access := Driver_List.Element (Iter);
               begin
                  if Name = D.Name.all then
                     return D;
                  end if;
               end;
               Driver_List.Next (Iter);
            end loop;
         end;
      end loop;
      return null;
   end Get_Driver;

end ADO.Drivers.Connections;

Implement the Set_Port procedure

Implement the Set_Port procedure


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

with Ada.Unchecked_Deallocation;

with ASF.Contexts.Faces;
with ASF.Applications.Messages.Factory;

package body ASF.Contexts.Exceptions is

   --  ------------------------------
   --  Take action to handle the Exception_Event instances that have been queued by
   --  calls to Application.Publish_Event.
   --
   --  This operation is called after each ASF phase by the life cycle manager.
   --  ------------------------------
   procedure Handle (Handler : in out Exception_Handler) is
      pragma Unreferenced (Handler);
      use ASF.Applications;
      use type ASF.Contexts.Faces.Faces_Context_Access;

      function Get_Message (Event   : in Events.Exceptions.Exception_Event'Class;
                            Context : in ASF.Contexts.Faces.Faces_Context'Class)
                            return ASF.Applications.Messages.Message;

      procedure Process (Event   : in Events.Exceptions.Exception_Event'Class;
                         Remove  : out Boolean;
                         Context : in out ASF.Contexts.Faces.Faces_Context'Class);

      --  ------------------------------
      --  Get a localized message for the exception
      --  ------------------------------
      function Get_Message (Event   : in Events.Exceptions.Exception_Event'Class;
                            Context : in ASF.Contexts.Faces.Faces_Context'Class)
                            return ASF.Applications.Messages.Message is
         Name : constant String := Event.Get_Exception_Name;
         Msg  : constant String := Event.Get_Exception_Message;
         Pos  : constant Util.Strings.Maps.Cursor := Handler.Mapping.Find (Name);
      begin
         if Util.Strings.Maps.Has_Element (Pos) then
            return Messages.Factory.Get_Message (Context    => Context,
                                                 Message_Id => Util.Strings.Maps.Element (Pos),
                                                 Param1     => Msg);
         elsif Msg'Length = 0 then
            return Messages.Factory.Get_Message (Context    => Context,
                                                 Message_Id => EXCEPTION_MESSAGE_BASIC_ID,
                                                 Param1     => Name);
         else
            return Messages.Factory.Get_Message (Context    => Context,
                                                 Message_Id => EXCEPTION_MESSAGE_EXTENDED_ID,
                                                 Param1     => Name,
                                                 Param2     => Msg);

         end if;
      end Get_Message;

      --  ------------------------------
      --  Process each exception event and add a message in the faces context.
      --  ------------------------------
      procedure Process (Event   : in Events.Exceptions.Exception_Event'Class;
                         Remove  : out Boolean;
                         Context : in out ASF.Contexts.Faces.Faces_Context'Class) is
         Msg : constant Messages.Message := Get_Message (Event, Context);
      begin
         Context.Add_Message (Client_Id => "",
                              Message   => Msg);
         Remove := True;
      end Process;

      Context : constant ASF.Contexts.Faces.Faces_Context_Access := ASF.Contexts.Faces.Current;

   begin
      if Context = null then
         return;
      end if;
      if Context.Get_Response_Completed then
         return;
      end if;
      Context.Iterate_Exception (Process'Access);
   end Handle;

   --  ------------------------------
   --  Set the message id to be used when a given exception name is raised.
   --  ------------------------------
   procedure Set_Message (Handler    : in out Exception_Handler;
                          Name       : in String;
                          Message_Id : in String) is
   begin
      Handler.Mapping.Insert (Name, Message_Id);
   end Set_Message;

   --  ------------------------------
   --  Queue an exception event to the exception handler.  The exception event will be
   --  processed at the end of the current ASF phase.
   --  ------------------------------
   procedure Queue_Exception (Queue : in out Exception_Queue;
                              Ex      : in Ada.Exceptions.Exception_Occurrence) is
   begin
      Queue.Unhandled_Events.Append (ASF.Events.Exceptions.Create_Exception_Event (Ex));
   end Queue_Exception;

   --  ------------------------------
   --  Clear the exception queue.
   --  ------------------------------
   overriding
   procedure Finalize (Queue : in out Exception_Queue) is

      procedure Free is
        new Ada.Unchecked_Deallocation (Object => ASF.Events.Exceptions.Exception_Event'Class,
                                        Name   => ASF.Events.Exceptions.Exception_Event_Access);

      Len : Natural;
   begin
      loop
         Len := Natural (Queue.Unhandled_Events.Length);
         exit when Len = 0;
         declare
            Event : ASF.Events.Exceptions.Exception_Event_Access
              := Queue.Unhandled_Events.Element (Len);
         begin
            Free (Event);
            Queue.Unhandled_Events.Delete (Len);
         end;
      end loop;
   end Finalize;

end ASF.Contexts.Exceptions;

-----------------------------------------------------------------------
--  asf-contexts-exceptions -- Exception handlers in faces context
--  Copyright (C) 2011, 2018, 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 ASF.Contexts.Faces;
with ASF.Applications.Messages.Factory;

package body ASF.Contexts.Exceptions is

   --  ------------------------------
   --  Take action to handle the Exception_Event instances that have been queued by
   --  calls to Application.Publish_Event.
   --
   --  This operation is called after each ASF phase by the life cycle manager.
   --  ------------------------------
   procedure Handle (Handler : in out Exception_Handler) is
      use ASF.Applications;
      use type ASF.Contexts.Faces.Faces_Context_Access;

      function Get_Message (Event   : in Events.Exceptions.Exception_Event'Class;
                            Context : in ASF.Contexts.Faces.Faces_Context'Class)
                            return ASF.Applications.Messages.Message;

      procedure Process (Event   : in Events.Exceptions.Exception_Event'Class;
                         Remove  : out Boolean;
                         Context : in out ASF.Contexts.Faces.Faces_Context'Class);

      --  ------------------------------
      --  Get a localized message for the exception
      --  ------------------------------
      function Get_Message (Event   : in Events.Exceptions.Exception_Event'Class;
                            Context : in ASF.Contexts.Faces.Faces_Context'Class)
                            return ASF.Applications.Messages.Message is
         Name : constant String := Event.Get_Exception_Name;
         Msg  : constant String := Event.Get_Exception_Message;
         Pos  : constant Util.Strings.Maps.Cursor := Handler.Mapping.Find (Name);
      begin
         if Util.Strings.Maps.Has_Element (Pos) then
            return Messages.Factory.Get_Message (Context    => Context,
                                                 Message_Id => Util.Strings.Maps.Element (Pos),
                                                 Param1     => Msg);
         elsif Msg'Length = 0 then
            return Messages.Factory.Get_Message (Context    => Context,
                                                 Message_Id => EXCEPTION_MESSAGE_BASIC_ID,
                                                 Param1     => Name);
         else
            return Messages.Factory.Get_Message (Context    => Context,
                                                 Message_Id => EXCEPTION_MESSAGE_EXTENDED_ID,
                                                 Param1     => Name,
                                                 Param2     => Msg);

         end if;
      end Get_Message;

      --  ------------------------------
      --  Process each exception event and add a message in the faces context.
      --  ------------------------------
      procedure Process (Event   : in Events.Exceptions.Exception_Event'Class;
                         Remove  : out Boolean;
                         Context : in out ASF.Contexts.Faces.Faces_Context'Class) is
         Msg : constant Messages.Message := Get_Message (Event, Context);
      begin
         Context.Add_Message (Client_Id => "",
                              Message   => Msg);
         Remove := True;
      end Process;

      Context : constant ASF.Contexts.Faces.Faces_Context_Access := ASF.Contexts.Faces.Current;

   begin
      if Context = null then
         return;
      end if;
      if Context.Get_Response_Completed then
         return;
      end if;
      Context.Iterate_Exception (Process'Access);
   end Handle;

   --  ------------------------------
   --  Set the message id to be used when a given exception name is raised.
   --  ------------------------------
   procedure Set_Message (Handler    : in out Exception_Handler;
                          Name       : in String;
                          Message_Id : in String) is
   begin
      Handler.Mapping.Insert (Name, Message_Id);
   end Set_Message;

   --  ------------------------------
   --  Queue an exception event to the exception handler.  The exception event will be
   --  processed at the end of the current ASF phase.
   --  ------------------------------
   procedure Queue_Exception (Queue : in out Exception_Queue;
                              Ex      : in Ada.Exceptions.Exception_Occurrence) is
   begin
      Queue.Unhandled_Events.Append (ASF.Events.Exceptions.Create_Exception_Event (Ex));
   end Queue_Exception;

   --  ------------------------------
   --  Clear the exception queue.
   --  ------------------------------
   overriding
   procedure Finalize (Queue : in out Exception_Queue) is

      procedure Free is
        new Ada.Unchecked_Deallocation (Object => ASF.Events.Exceptions.Exception_Event'Class,
                                        Name   => ASF.Events.Exceptions.Exception_Event_Access);

      Len : Natural;
   begin
      loop
         Len := Natural (Queue.Unhandled_Events.Length);
         exit when Len = 0;
         declare
            Event : ASF.Events.Exceptions.Exception_Event_Access
              := Queue.Unhandled_Events.Element (Len);
         begin
            Free (Event);
            Queue.Unhandled_Events.Delete (Len);
         end;
      end loop;
   end Finalize;

end ASF.Contexts.Exceptions;

Fix compilation warning

Fix compilation warning


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

with Util.Log.Loggers;

with AWS.Net.SSL;
with AWS.Config.Set;
with ASF.Server.Web;
with AWA.Setup.Applications;

with Atlas.Applications;
procedure Atlas.Server is

   procedure Configure (Config : in out AWS.Config.Object);

   Log     : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Atlas.Server");
   App     : constant Atlas.Applications.Application_Access := new Atlas.Applications.Application;
   WS      : ASF.Server.Web.AWS_Container;

   procedure Setup is
     new AWA.Setup.Applications.Configure (Atlas.Applications.Application'Class,
                                           Atlas.Applications.Application_Access,
                                           Atlas.Applications.Initialize);

   procedure Configure (Config : in out AWS.Config.Object) is
   begin
      AWS.Config.Set.Input_Line_Size_Limit (1_000_000);
      AWS.Config.Set.Max_Connection (Config, 2);
      AWS.Config.Set.Accept_Queue_Size (Config, 100);
      AWS.Config.Set.Send_Buffer_Size (Config, 128 * 1024);
      AWS.Config.Set.Upload_Size_Limit (Config, 100_000_000);
   end Configure;

begin
   WS.Configure (Configure'Access);
   WS.Start;
   Log.Info ("Connect you browser to: http://localhost:8080{0}/index.html",
             Atlas.Applications.CONTEXT_PATH);
   Setup (WS, App, "atlas", Atlas.Applications.CONTEXT_PATH);
   if not AWS.Net.SSL.Is_Supported then
      Log.Error ("SSL is not supported by AWS.");
      Log.Error ("SSL is required for the OAuth2/OpenID connector to "
                 & "connect to OAuth2/OpenID providers.");
      Log.Error ("Please, rebuild AWS with SSL support.");
   end if;
   delay 365.0 * 24.0 * 3600.0;
   App.Close;
exception
   when E : others =>
      Log.Error ("Exception in server: " &
                 Ada.Exceptions.Exception_Name (E) & ": " &
                 Ada.Exceptions.Exception_Message (E));
end Atlas.Server;

-----------------------------------------------------------------------
--  atlas-server -- Application server
--  Copyright (C) 2011, 2012, 2013, 2016, 2017, 2018, 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.Exceptions;

with Util.Log.Loggers;

with ADO.Drivers;
with AWS.Net.SSL;
with AWS.Config.Set;
with ASF.Server.Web;
with AWA.Setup.Applications;

with Atlas.Applications;
procedure Atlas.Server is

   procedure Configure (Config : in out AWS.Config.Object);

   Log     : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Atlas.Server");
   App     : constant Atlas.Applications.Application_Access := new Atlas.Applications.Application;
   WS      : ASF.Server.Web.AWS_Container;

   procedure Setup is
     new AWA.Setup.Applications.Configure (Atlas.Applications.Application'Class,
                                           Atlas.Applications.Application_Access,
                                           Atlas.Applications.Initialize);

   procedure Configure (Config : in out AWS.Config.Object) is
   begin
      AWS.Config.Set.Input_Line_Size_Limit (1_000_000);
      AWS.Config.Set.Max_Connection (Config, 2);
      AWS.Config.Set.Accept_Queue_Size (Config, 100);
      AWS.Config.Set.Send_Buffer_Size (Config, 128 * 1024);
      AWS.Config.Set.Upload_Size_Limit (Config, 100_000_000);
   end Configure;

begin
   ADO.Drivers.Initialize;
   WS.Configure (Configure'Access);
   WS.Start;
   Log.Info ("Connect you browser to: http://localhost:8080{0}/index.html",
             Atlas.Applications.CONTEXT_PATH);
   Setup (WS, App, "atlas", Atlas.Applications.CONTEXT_PATH);
   if not AWS.Net.SSL.Is_Supported then
      Log.Error ("SSL is not supported by AWS.");
      Log.Error ("SSL is required for the OAuth2/OpenID connector to "
                 & "connect to OAuth2/OpenID providers.");
      Log.Error ("Please, rebuild AWS with SSL support.");
   end if;
   delay 365.0 * 24.0 * 3600.0;
   App.Close;
exception
   when E : others =>
      Log.Error ("Exception in server: " &
                 Ada.Exceptions.Exception_Name (E) & ": " &
                 Ada.Exceptions.Exception_Message (E));
end Atlas.Server;

Call ADO.Drivers.Initialize to setup all known database drivers


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

with Utilities;
with Ada.Characters.Latin_1;

package body Port_Specification.Json is

   package UTL renames Utilities;
   package LAT renames Ada.Characters.Latin_1;

   --------------------------------------------------------------------------------------------
   --  describe_port
   --------------------------------------------------------------------------------------------
   procedure describe_port
     (specs   : Portspecs;
      dossier : TIO.File_Type;
      bucket  : String;
      index   : Positive)
   is
      fpcval : constant String := fpc_value (specs.generated, specs.equivalent_fpc_port);
      nvar   : constant Natural := specs.get_number_of_variants;
   begin
      TIO.Put
        (dossier,
           UTL.json_object (True, 3, index) &
           UTL.json_nvpair_string  ("bucket",   bucket, 1, pad) &
           UTL.json_nvpair_string  ("namebase", specs.get_namebase, 2, pad) &
           UTL.json_nvpair_string  ("version",  specs.get_field_value (sp_version), 3, pad) &
           homepage_line (specs) &
           UTL.json_nvpair_string  ("FPC",      fpcval, 3, pad) &
           UTL.json_nvpair_complex ("keywords", describe_keywords (specs), 3, pad) &
           UTL.json_nvpair_complex ("distfile", describe_distfiles (specs), 3, pad) &
           specs.get_json_contacts &
           describe_Common_Platform_Enumeration (specs) &
           UTL.json_name_complex   ("variants", 4, pad) &
           UTL.json_array (True, pad + 1)
        );
      for x in 1 .. nvar loop
         declare
            varstr : constant String := specs.get_list_item (Port_Specification.sp_variants, x);
            sdesc  : constant String := escape_tagline (specs.get_tagline (varstr));
            spray  : constant String := describe_subpackages (specs, varstr);
         begin
            TIO.Put
              (dossier,
               UTL.json_object (True, pad + 2, x) &
                 UTL.json_nvpair_string  ("label", varstr, 1, pad + 3) &
                 UTL.json_nvpair_string  ("sdesc", sdesc, 2, pad + 3) &
                 UTL.json_nvpair_complex ("spkgs", spray, 3, pad + 3) &
                 UTL.json_object (False, pad + 2, x)
              );
         end;
      end loop;
      TIO.Put
        (dossier,
           UTL.json_array (False, pad + 1) &
           UTL.json_object (False, 3, index)
        );

   end describe_port;

   --------------------------------------------------------------------------------------------
   --  fpc_value
   --------------------------------------------------------------------------------------------
   function fpc_value (is_generated : Boolean; raw_value : String) return String is
   begin
      if is_generated then
         return "generated";
      else
         return raw_value;
      end if;
   end fpc_value;

   --------------------------------------------------------------------------------------------
   --  describe_keywords
   --------------------------------------------------------------------------------------------
   function describe_keywords (specs : Portspecs) return String
   is
      raw : constant String := specs.get_field_value (Port_Specification.sp_keywords);
      innerquote : constant String :=
        HT.replace_char
          (S         => HT.replace_char (raw, LAT.Comma, LAT.Quotation & LAT.Comma),
           focus     => LAT.Space,
           substring => LAT.Space & LAT.Quotation);
   begin
      return "[ " & LAT.Quotation & innerquote  & LAT.Quotation & " ]";
   end describe_keywords;

   --------------------------------------------------------------------------------------------
   --  describe_distfiles
   --------------------------------------------------------------------------------------------
   function describe_distfiles (specs : Portspecs) return String
   is
      numfiles : constant Natural := specs.get_list_length (Port_Specification.sp_distfiles);
      result   : HT.Text := HT.SUS ("[ ");
   begin
      for x in 1 .. numfiles loop
         if x > 1 then
            HT.SU.Append (result, ", ");
         end if;
         HT.SU.Append (result, LAT.Quotation & specs.get_repology_distfile (x) & LAT.Quotation);
      end loop;
      return HT.USS (result) & " ]";
   end describe_distfiles;

   --------------------------------------------------------------------------------------------
   --  describe_subpackages
   --------------------------------------------------------------------------------------------
   function describe_subpackages (specs : Portspecs; variant : String) return String
   is
      numpkg : constant Natural := specs.get_subpackage_length (variant);
      result   : HT.Text := HT.SUS ("[ ");
   begin
      for x in 1 .. numpkg loop
         if x > 1 then
            HT.SU.Append (result, ", ");
         end if;
         HT.SU.Append (result, LAT.Quotation &
                         specs.get_subpackage_item (variant, x) & LAT.Quotation);
      end loop;
      return HT.USS (result) & " ]";
   end describe_subpackages;

   --------------------------------------------------------------------------------------------
   --  escape_tagline
   --------------------------------------------------------------------------------------------
   function escape_tagline (raw : String) return String
   is
      focus : constant String :=
        LAT.Reverse_Solidus &
        LAT.Quotation &
        LAT.Solidus &
        LAT.BS &
        LAT.FF &
        LAT.LF &
        LAT.CR &
        LAT.HT;
      curlen : Natural := raw'Length;
      result : String (1 .. raw'Length * 2) := (others => ' ');
   begin
      result (1 .. curlen) := raw;
      for x in focus'Range loop
         if HT.count_char (result (1 .. curlen), focus (x)) > 0 then
            declare
               newstr : String := HT.replace_char (result (1 .. curlen), focus (x),
                                                   LAT.Reverse_Solidus & focus (x));
            begin
               curlen := newstr'Length;
               result (1 .. curlen) := newstr;
            end;
         end if;
      end loop;
      return result (1 .. curlen);
   end escape_tagline;

   --------------------------------------------------------------------------------------------
   --  homepage_line
   --------------------------------------------------------------------------------------------
   function homepage_line (specs : Portspecs) return String
   is
      homepage : constant String := specs.get_field_value (sp_homepage);
   begin
      if homepage = homepage_none or else
        specs.repology_sucks
      then
         return "";
      end if;
      return UTL.json_nvpair_string  ("homepage", specs.get_field_value (sp_homepage), 3, pad);
   end homepage_line;

   --------------------------------------------------------------------------------------------
   --  describe_Common_Platform_Enumeration
   --------------------------------------------------------------------------------------------
   function describe_Common_Platform_Enumeration (specs : Portspecs) return String
   is
      function retrieve (key : String; default_value : String) return String;
      function form_object (product, vendor : String) return String;

      function retrieve (key : String; default_value : String) return String
      is
         key_text : HT.Text := HT.SUS (key);
      begin
         if specs.catch_all.Contains (key_text) then
            return HT.USS (specs.catch_all.Element (key_text).list.First_Element);
         else
            return default_value;
         end if;
      end retrieve;

      function form_object (product, vendor : String) return String
      is
         data1 : String := UTL.json_nvpair_string ("product", product, 1, 0);  -- trailing LF
         data2 : String := UTL.json_nvpair_string ("vendor", vendor, 1, 0);    -- trailing LF
      begin
         return "{" & data1 (data1'First .. data1'Last - 1) & LAT.Comma
                     & data2 (data2'First .. data2'Last - 1) & " }";
      end form_object;
   begin
      if not specs.uses.Contains (HT.SUS ("cpe")) then
         return "";
      end if;

      declare
         cpe_product : String := retrieve ("CPE_PRODUCT", HT.lowercase (specs.get_namebase));
         cpe_vendor  : String := retrieve ("CPE_VENDOR", cpe_product);
      begin
         return UTL.json_nvpair_complex ("cpe", form_object (cpe_product, cpe_vendor), 3, pad);
      end;
   end describe_Common_Platform_Enumeration;

end Port_Specification.Json;

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

with Utilities;
with Ada.Characters.Latin_1;
with HelperText;

package body Port_Specification.Json is

   package LAT renames Ada.Characters.Latin_1;
   package UTL renames Utilities;
   package HT  renames HelperText;

   --------------------------------------------------------------------------------------------
   --  describe_port
   --------------------------------------------------------------------------------------------
   procedure describe_port
     (specs   : Portspecs;
      dossier : TIO.File_Type;
      bucket  : String;
      index   : Positive)
   is
      fpcval : constant String := fpc_value (specs.generated, specs.equivalent_fpc_port);
      nvar   : constant Natural := specs.get_number_of_variants;
   begin
      TIO.Put
        (dossier,
           UTL.json_object (True, 3, index) &
           UTL.json_nvpair_string  ("bucket",   bucket, 1, pad) &
           UTL.json_nvpair_string  ("namebase", specs.get_namebase, 2, pad) &
           UTL.json_nvpair_string  ("version",  specs.get_field_value (sp_version), 3, pad) &
           homepage_line (specs) &
           UTL.json_nvpair_string  ("FPC",      fpcval, 3, pad) &
           UTL.json_nvpair_complex ("keywords", describe_keywords (specs), 3, pad) &
           UTL.json_nvpair_complex ("distfile", describe_distfiles (specs), 3, pad) &
           specs.get_json_contacts &
           describe_Common_Platform_Enumeration (specs) &
           UTL.json_name_complex   ("variants", 4, pad) &
           UTL.json_array (True, pad + 1)
        );
      for x in 1 .. nvar loop
         declare
            varstr : constant String := specs.get_list_item (Port_Specification.sp_variants, x);
            sdesc  : constant String := escape_tagline (specs.get_tagline (varstr));
            spray  : constant String := describe_subpackages (specs, varstr);
         begin
            TIO.Put
              (dossier,
               UTL.json_object (True, pad + 2, x) &
                 UTL.json_nvpair_string  ("label", varstr, 1, pad + 3) &
                 UTL.json_nvpair_string  ("sdesc", sdesc, 2, pad + 3) &
                 UTL.json_nvpair_complex ("spkgs", spray, 3, pad + 3) &
                 UTL.json_object (False, pad + 2, x)
              );
         end;
      end loop;
      TIO.Put
        (dossier,
           UTL.json_array (False, pad + 1) &
           UTL.json_object (False, 3, index)
        );

   end describe_port;

   --------------------------------------------------------------------------------------------
   --  fpc_value
   --------------------------------------------------------------------------------------------
   function fpc_value (is_generated : Boolean; raw_value : String) return String is
   begin
      if is_generated then
         return "generated";
      else
         return raw_value;
      end if;
   end fpc_value;

   --------------------------------------------------------------------------------------------
   --  describe_keywords
   --------------------------------------------------------------------------------------------
   function describe_keywords (specs : Portspecs) return String
   is
      raw : constant String := specs.get_field_value (Port_Specification.sp_keywords);
      innerquote : constant String :=
        HT.replace_char
          (S         => HT.replace_char (raw, LAT.Comma, LAT.Quotation & LAT.Comma),
           focus     => LAT.Space,
           substring => LAT.Space & LAT.Quotation);
   begin
      return "[ " & LAT.Quotation & innerquote  & LAT.Quotation & " ]";
   end describe_keywords;

   --------------------------------------------------------------------------------------------
   --  describe_distfiles
   --------------------------------------------------------------------------------------------
   function describe_distfiles (specs : Portspecs) return String
   is
      numfiles : constant Natural := specs.get_list_length (Port_Specification.sp_distfiles);
      result   : HT.Text := HT.SUS ("[ ");
   begin
      for x in 1 .. numfiles loop
         if x > 1 then
            HT.SU.Append (result, ", ");
         end if;
         HT.SU.Append (result, LAT.Quotation & specs.get_repology_distfile (x) & LAT.Quotation);
      end loop;
      return HT.USS (result) & " ]";
   end describe_distfiles;

   --------------------------------------------------------------------------------------------
   --  describe_subpackages
   --------------------------------------------------------------------------------------------
   function describe_subpackages (specs : Portspecs; variant : String) return String
   is
      numpkg : constant Natural := specs.get_subpackage_length (variant);
      result   : HT.Text := HT.SUS ("[ ");
   begin
      for x in 1 .. numpkg loop
         if x > 1 then
            HT.SU.Append (result, ", ");
         end if;
         HT.SU.Append (result, LAT.Quotation &
                         specs.get_subpackage_item (variant, x) & LAT.Quotation);
      end loop;
      return HT.USS (result) & " ]";
   end describe_subpackages;

   --------------------------------------------------------------------------------------------
   --  escape_tagline
   --------------------------------------------------------------------------------------------
   function escape_tagline (raw : String) return String
   is
      focus : constant String :=
        LAT.Reverse_Solidus &
        LAT.Quotation &
        LAT.Solidus &
        LAT.BS &
        LAT.FF &
        LAT.LF &
        LAT.CR &
        LAT.HT;
      curlen : Natural := raw'Length;
      result : String (1 .. raw'Length * 2) := (others => ' ');
   begin
      result (1 .. curlen) := raw;
      for x in focus'Range loop
         if HT.count_char (result (1 .. curlen), focus (x)) > 0 then
            declare
               newstr : String := HT.replace_char (result (1 .. curlen), focus (x),
                                                   LAT.Reverse_Solidus & focus (x));
            begin
               curlen := newstr'Length;
               result (1 .. curlen) := newstr;
            end;
         end if;
      end loop;
      return result (1 .. curlen);
   end escape_tagline;

   --------------------------------------------------------------------------------------------
   --  homepage_line
   --------------------------------------------------------------------------------------------
   function homepage_line (specs : Portspecs) return String
   is
      homepage : constant String := specs.get_field_value (sp_homepage);
   begin
      if homepage = homepage_none or else
        specs.repology_sucks
      then
         return "";
      end if;
      return UTL.json_nvpair_string  ("homepage", specs.get_field_value (sp_homepage), 3, pad);
   end homepage_line;

   --------------------------------------------------------------------------------------------
   --  describe_Common_Platform_Enumeration
   --------------------------------------------------------------------------------------------
   function describe_Common_Platform_Enumeration (specs : Portspecs) return String
   is
      function retrieve (key : String; default_value : String) return String;
      function form_object return String;
      procedure maybe_push (json_key, cpe_key, default_value : String);
      procedure always_push (json_key, value : String);

      pairs : string_crate.Vector;

      function retrieve (key : String; default_value : String) return String
      is
         key_text : HT.Text := HT.SUS (key);
      begin
         if specs.catch_all.Contains (key_text) then
            return HT.USS (specs.catch_all.Element (key_text).list.First_Element);
         else
            return default_value;
         end if;
      end retrieve;

      procedure always_push (json_key, value : String) is
      begin
         pairs.Append (HT.SUS (json_key & "=" & value));
      end always_push;

      procedure maybe_push (json_key, cpe_key, default_value : String)
      is
         cpe_key_text : HT.Text := HT.SUS (cpe_key);
         cpe_value    : HT.Text;
      begin
         if specs.catch_all.Contains (cpe_key_text) then
            cpe_value := specs.catch_all.Element (cpe_key_text).list.First_Element;
            if not HT.equivalent (cpe_value, default_value) then
               pairs.Append (HT.SUS (json_key & "=" & HT.USS (cpe_value)));
            end if;
         end if;
      end maybe_push;

      function form_object return String
      is
         procedure dump (position : string_crate.Cursor);

         tracker : Natural := 0;
         guts    : HT.Text;

         procedure dump (position : string_crate.Cursor)
         is
            both  : String := HT.USS (string_crate.Element (position));
            key   : String := HT.part_1 (both, "=");
            value : String := HT.part_2 (both, "=");
            data  : String := UTL.json_nvpair_string (key, value, 1, 0);  -- trailing LF
         begin
            tracker := tracker + 1;
            if tracker > 1 then
               HT.SU.Append (guts, LAT.Comma);
            end if;
            HT.SU.Append (guts, data (data'First .. data'Last - 1));
         end dump;
      begin
         pairs.Iterate (dump'Access);
         return "{" & HT.USS (guts) & " }";
      end form_object;
   begin
      if not specs.uses.Contains (HT.SUS ("cpe")) then
         return "";
      end if;

      maybe_push  ("part", "CPE_PART", "a");

      declare
         cpe_product : String := retrieve ("CPE_PRODUCT", HT.lowercase (specs.get_namebase));
         cpe_vendor  : String := retrieve ("CPE_VENDOR", cpe_product);
      begin
         --  probably should be vendor then product, but this was the original order
         --  of repology json.  Maintain order to avoid massive diff.
         always_push ("product", cpe_product);
         always_push ("vendor", cpe_vendor);
      end;

      maybe_push ("version", "CPE_VERSION", HT.USS (specs.version));
      maybe_push ("update", "CPE_UPDATE", "");
      maybe_push ("edition", "CPE_EDITION", "");
      maybe_push ("lang", "CPE_LANG", "");
      maybe_push ("sw_edition", "CPE_SW_EDITION", "");
      maybe_push ("target_sw", "CPE_TARGET_SW", "take-anything");
      maybe_push ("target_hw", "CPE_TARGET_HW", "x86-x86-arm64");
      maybe_push ("other", "CPE_OTHER",  HT.USS (specs.version));

      return UTL.json_nvpair_complex ("cpe", form_object, 3, pad);
   end describe_Common_Platform_Enumeration;

end Port_Specification.Json;

expand CPE output to repology.json

expand CPE output to repology.json

If any of the new 9 fields are defined to something other than its
default, add it to the json object.  any definition of CPE_TARGET_SW and
CPE_TARGET_HW are always taken (no default)


-----------------------------------------------------------------------
--  security-policies-roles -- Role based 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.Strings.Unbounded;

--  == Role Based Security Policy ==
--  The <tt>Security.Policies.Roles</tt> package implements a role based security policy.
--
--  A role is represented by a name in security configuration files.  A role based permission
--  is associated with a list of roles.  The permission is granted if the user has one of these
--  roles.
--
--    <security-role>
--      <role-name>admin</role-name>
--    </security-role>
--    <security-role>
--      <role-name>manager</role-name>
--    </security-role>
--    <role-permission>
--      <name>create-workspace</name>
--      <role>admin</role>
--      <role>manager</role>
--    </role-permission>
--
--  This definition declares two roles: <tt>admin</tt> and <tt>manager</tt>
--  It defines a permission create-workspace that will be granted if the
--  user has either the admin or the manager role.
--
--  A <tt>Security_Context</tt> must be associated with a set of roles before checking the
--  permission.  This is done by using the <tt>Set_Role_Context</tt> operation:
--
--     Security.Policies.Roles.Set_Role_Context (Security.Contexts.Current, "admin");
--
package Security.Policies.Roles is

   NAME : constant String := "Role-Policy";

   --  Each role is represented by a Role_Type number to provide a fast
   --  and efficient role check.
   type Role_Type is new Natural range 0 .. 63;
   for Role_Type'Size use 8;

   type Role_Type_Array is array (Positive range <>) of Role_Type;

   --  The Role_Map represents a set of roles which are assigned to a user.
   --  Each role is represented by a boolean in the map.  The implementation is limited
   --  to 64 roles (the number of different permissions can be higher).
   type Role_Map is array (Role_Type'Range) of Boolean;
   pragma Pack (Role_Map);

   --  ------------------------------
   --  Policy context
   --  ------------------------------
   --  The Role_Policy_Context gives security context information that the role
   --  based policy can use to verify the permission.
   type Role_Policy_Context is new Policy_Context with record
      Roles : Role_Map;
   end record;
   type Role_Policy_Context_Access is access all Role_Policy_Context'Class;

   --  Set the roles which are assigned to the user in the security context.
   --  The role policy will use these roles to verify a permission.
   procedure Set_Role_Context (Context : in out Security.Contexts.Security_Context'Class;
                               Roles   : in Role_Map);

   --  Set the roles which are assigned to the user in the security context.
   --  The role policy will use these roles to verify a permission.
   procedure Set_Role_Context (Context : in out Security.Contexts.Security_Context'Class;
                               Roles   : in String);

   --  ------------------------------
   --  Role based policy
   --  ------------------------------
   type Role_Policy is new Policy with private;
   type Role_Policy_Access is access all Role_Policy'Class;

   Invalid_Name : exception;

   --  Get the policy name.
   overriding
   function Get_Name (From : in Role_Policy) return String;

   --  Find the role type associated with the role name identified by Name.
   --  Raises Invalid_Name if there is no role type.
   function Find_Role (Manager : in Role_Policy;
                       Name    : in String) return Role_Type;

   --  Get the role name.
   function Get_Role_Name (Manager : in Role_Policy;
                           Role    : in Role_Type) return String;

   --  Create a role
   procedure Create_Role (Manager : in out Role_Policy;
                          Name    : in String;
                          Role    : out Role_Type);

   --  Get or add a role type for the given name.
   procedure Add_Role_Type (Manager   : in out Role_Policy;
                            Name      : in String;
                            Result    : out Role_Type);

   --  Set the roles specified in the <tt>Roles</tt> parameter.  Each role is represented by
   --  its name and multiple roles are separated by ','.
   --  Raises Invalid_Name if a role was not found.
   procedure Set_Roles (Manager : in Role_Policy;
                        Roles   : in String;
                        Into    : out Role_Map);

   --  Setup the XML parser to read the role-permission description.
   overriding
   procedure Prepare_Config (Policy : in out Role_Policy;
                             Reader : in out Util.Serialize.IO.XML.Parser);

   --  Finalize the policy manager.
   overriding
   procedure Finalize (Policy : in out Role_Policy);

private

   type Role_Name_Array is
     array (Role_Type'Range) of Ada.Strings.Unbounded.String_Access;

   type Role_Policy is new Policy with record
      Names        : Role_Name_Array;
      Next_Role    : Role_Type := Role_Type'First;
   end record;

   type Controller_Config is record
      Name    : Util.Beans.Objects.Object;
      Roles   : Role_Type_Array (1 .. Integer (Role_Type'Last));
      Count   : Natural := 0;
      Manager : Role_Policy_Access;
   end record;

end Security.Policies.Roles;

-----------------------------------------------------------------------
--  security-policies-roles -- Role based 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.Strings.Unbounded;

--  == Role Based Security Policy ==
--  The <tt>Security.Policies.Roles</tt> package implements a role based security policy.
--
--  === Policy creation ===
--  An instance of the <tt>Role_Policy</tt> must be created and registered in the policy manager.
--  Get or declare the following variables:
--
--    Manager : Security.Policies.Policy_Manager;
--    Policy  : Security.Policies.Roles.Role_Policy_Access;
--
--  Create the role policy and register it in the policy manager as follows:
--
--    Policy := new Role_Policy;
--    Manager.Add_Policy (Policy.all'Access);
--
--  === Policy Configuration ===
--  A role is represented by a name in security configuration files.  A role based permission
--  is associated with a list of roles.  The permission is granted if the user has one of these
--  roles.  When the role based policy is registered in the policy manager, the following
--  XML configuration is used:
--
--    <security-role>
--      <role-name>admin</role-name>
--    </security-role>
--    <security-role>
--      <role-name>manager</role-name>
--    </security-role>
--    <role-permission>
--      <name>create-workspace</name>
--      <role>admin</role>
--      <role>manager</role>
--    </role-permission>
--
--  This definition declares two roles: <tt>admin</tt> and <tt>manager</tt>
--  It defines a permission create-workspace that will be granted if the
--  user has either the admin or the manager role.
--
--  Each role is identified by a name in the configuration file.  It is represented by
--  a <tt>Role_Type</tt>.  To provide an efficient implementation, the <tt>Role_Type</tt>
--  is represented as an integer with a limit of 64 different roles.
--
--  === Assigning roles to users ===
--  A <tt>Security_Context</tt> must be associated with a set of roles before checking the
--  permission.  This is done by using the <tt>Set_Role_Context</tt> operation:
--
--     Security.Policies.Roles.Set_Role_Context (Security.Contexts.Current, "admin");
--
package Security.Policies.Roles is

   NAME : constant String := "Role-Policy";

   --  Each role is represented by a Role_Type number to provide a fast
   --  and efficient role check.
   type Role_Type is new Natural range 0 .. 63;
   for Role_Type'Size use 8;

   type Role_Type_Array is array (Positive range <>) of Role_Type;

   --  The Role_Map represents a set of roles which are assigned to a user.
   --  Each role is represented by a boolean in the map.  The implementation is limited
   --  to 64 roles (the number of different permissions can be higher).
   type Role_Map is array (Role_Type'Range) of Boolean;
   pragma Pack (Role_Map);

   --  ------------------------------
   --  Policy context
   --  ------------------------------
   --  The Role_Policy_Context gives security context information that the role
   --  based policy can use to verify the permission.
   type Role_Policy_Context is new Policy_Context with record
      Roles : Role_Map;
   end record;
   type Role_Policy_Context_Access is access all Role_Policy_Context'Class;

   --  Set the roles which are assigned to the user in the security context.
   --  The role policy will use these roles to verify a permission.
   procedure Set_Role_Context (Context : in out Security.Contexts.Security_Context'Class;
                               Roles   : in Role_Map);

   --  Set the roles which are assigned to the user in the security context.
   --  The role policy will use these roles to verify a permission.
   procedure Set_Role_Context (Context : in out Security.Contexts.Security_Context'Class;
                               Roles   : in String);

   --  ------------------------------
   --  Role based policy
   --  ------------------------------
   type Role_Policy is new Policy with private;
   type Role_Policy_Access is access all Role_Policy'Class;

   Invalid_Name : exception;

   --  Get the policy name.
   overriding
   function Get_Name (From : in Role_Policy) return String;

   --  Find the role type associated with the role name identified by Name.
   --  Raises Invalid_Name if there is no role type.
   function Find_Role (Manager : in Role_Policy;
                       Name    : in String) return Role_Type;

   --  Get the role name.
   function Get_Role_Name (Manager : in Role_Policy;
                           Role    : in Role_Type) return String;

   --  Create a role
   procedure Create_Role (Manager : in out Role_Policy;
                          Name    : in String;
                          Role    : out Role_Type);

   --  Get or add a role type for the given name.
   procedure Add_Role_Type (Manager   : in out Role_Policy;
                            Name      : in String;
                            Result    : out Role_Type);

   --  Set the roles specified in the <tt>Roles</tt> parameter.  Each role is represented by
   --  its name and multiple roles are separated by ','.
   --  Raises Invalid_Name if a role was not found.
   procedure Set_Roles (Manager : in Role_Policy;
                        Roles   : in String;
                        Into    : out Role_Map);

   --  Setup the XML parser to read the role-permission description.
   overriding
   procedure Prepare_Config (Policy : in out Role_Policy;
                             Reader : in out Util.Serialize.IO.XML.Parser);

   --  Finalize the policy manager.
   overriding
   procedure Finalize (Policy : in out Role_Policy);

private

   type Role_Name_Array is
     array (Role_Type'Range) of Ada.Strings.Unbounded.String_Access;

   type Role_Policy is new Policy with record
      Names        : Role_Name_Array;
      Next_Role    : Role_Type := Role_Type'First;
   end record;

   type Controller_Config is record
      Name    : Util.Beans.Objects.Object;
      Roles   : Role_Type_Array (1 .. Integer (Role_Type'Last));
      Count   : Natural := 0;
      Manager : Role_Policy_Access;
   end record;

end Security.Policies.Roles;

Document the role based policy

Document the role based policy


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

with Util.Locales;
with Util.Strings;
with Util.Properties.Bundles;

with ASF.Locales;
with ASF.Utils;
with ASF.Applications.Main;

package body ASF.Converters.Sizes is

   ONE_KB  : constant Long_Long_Integer := 1_024;
   ONE_MB  : constant Long_Long_Integer := ONE_KB * 1_024;
   ONE_GB  : constant Long_Long_Integer := ONE_MB * 1_024;

   UNIT_GB : aliased constant String := "size_giga_bytes";
   UNIT_MB : aliased constant String := "size_mega_bytes";
   UNIT_KB : aliased constant String := "size_kilo_bytes";
   UNIT_B  : aliased constant String := "size_bytes";

   --  ------------------------------
   --  Convert the object value into a string.  The object value is associated
   --  with the specified component.
   --  If the string cannot be converted, the Invalid_Conversion exception should be raised.
   --  ------------------------------
   function To_String (Convert   : in Size_Converter;
                       Context   : in ASF.Contexts.Faces.Faces_Context'Class;
                       Component : in ASF.Components.Base.UIComponent'Class;
                       Value     : in Util.Beans.Objects.Object) return String is
      pragma Unreferenced (Convert);

      Bundle  : ASF.Locales.Bundle;
      Locale  : constant Util.Locales.Locale := Context.Get_Locale;
   begin
      begin
         Context.Get_Application.Load_Bundle (Name   => "sizes",
                                              Locale => Util.Locales.To_String (Locale),
                                              Bundle => Bundle);

      exception
         when E : Util.Properties.Bundles.NO_BUNDLE =>
            Component.Log_Error ("Cannot localize sizes: {0}",
                                 Ada.Exceptions.Exception_Message (E));
      end;

      --  Convert the value as an integer here so that we can raise
      --  the Invalid_Conversion exception.
      declare
         Size    : constant Long_Long_Integer := Util.Beans.Objects.To_Long_Long_Integer (Value);
         Val     : Integer;
         Values  : ASF.Utils.Object_Array (1 .. 1);
         Result  : Ada.Strings.Unbounded.Unbounded_String;
         Unit    : Util.Strings.Name_Access;
      begin
         if Size >= ONE_GB then
            Val  := Integer ((Size + ONE_GB / 2) / ONE_GB);
            Unit := UNIT_GB'Access;

         elsif Size >= ONE_MB then
            Val  := Integer ((Size + ONE_MB / 2) / ONE_MB);
            Unit := UNIT_MB'Access;

         elsif Size >= ONE_KB then
            Val  := Integer ((Size + ONE_KB / 2) / ONE_KB);
            Unit := UNIT_KB'Access;

         else
            Val  := Integer (Size);
            Unit := UNIT_B'Access;
         end if;
         Values (1) := Util.Beans.Objects.To_Object (Val);
         ASF.Utils.Formats.Format (Bundle.Get (Unit.all), Values, Result);
         return Ada.Strings.Unbounded.To_String (Result);
      end;

   exception
      when E : others =>
         raise ASF.Converters.Invalid_Conversion with Ada.Exceptions.Exception_Message (E);
   end To_String;

   --  ------------------------------
   --  Convert the date string into an object for the specified component.
   --  If the string cannot be converted, the Invalid_Conversion exception should be raised.
   --  ------------------------------
   function To_Object (Convert   : in Size_Converter;
                       Context   : in ASF.Contexts.Faces.Faces_Context'Class;
                       Component : in ASF.Components.Base.UIComponent'Class;
                       Value     : in String) return Util.Beans.Objects.Object is
      pragma Unreferenced (Convert, Context, Value);
   begin
      Component.Log_Error ("Conversion of string to a size is not implemented");
      raise ASF.Converters.Invalid_Conversion with "Not implemented";
      return Util.Beans.Objects.Null_Object;
   end To_Object;

end ASF.Converters.Sizes;

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

with Util.Locales;
with Util.Strings;
with Util.Properties.Bundles;

with ASF.Locales;
with ASF.Utils;
with ASF.Applications.Main;

package body ASF.Converters.Sizes is

   ONE_KB  : constant Long_Long_Integer := 1_024;
   ONE_MB  : constant Long_Long_Integer := ONE_KB * 1_024;
   ONE_GB  : constant Long_Long_Integer := ONE_MB * 1_024;

   UNIT_GB : aliased constant String := "size_giga_bytes";
   UNIT_MB : aliased constant String := "size_mega_bytes";
   UNIT_KB : aliased constant String := "size_kilo_bytes";
   UNIT_B  : aliased constant String := "size_bytes";

   --  ------------------------------
   --  Convert the object value into a string.  The object value is associated
   --  with the specified component.
   --  If the string cannot be converted, the Invalid_Conversion exception should be raised.
   --  ------------------------------
   function To_String (Convert   : in Size_Converter;
                       Context   : in ASF.Contexts.Faces.Faces_Context'Class;
                       Component : in ASF.Components.Base.UIComponent'Class;
                       Value     : in Util.Beans.Objects.Object) return String is
      pragma Unreferenced (Convert);

      Bundle  : ASF.Locales.Bundle;
      Locale  : constant Util.Locales.Locale := Context.Get_Locale;
   begin
      begin
         ASF.Applications.Main.Load_Bundle (Context.Get_Application.all,
                                            Name   => "sizes",
                                            Locale => Util.Locales.To_String (Locale),
                                            Bundle => Bundle);

      exception
         when E : Util.Properties.Bundles.NO_BUNDLE =>
            Component.Log_Error ("Cannot localize sizes: {0}",
                                 Ada.Exceptions.Exception_Message (E));
      end;

      --  Convert the value as an integer here so that we can raise
      --  the Invalid_Conversion exception.
      declare
         Size    : constant Long_Long_Integer := Util.Beans.Objects.To_Long_Long_Integer (Value);
         Val     : Integer;
         Values  : ASF.Utils.Object_Array (1 .. 1);
         Result  : Ada.Strings.Unbounded.Unbounded_String;
         Unit    : Util.Strings.Name_Access;
      begin
         if Size >= ONE_GB then
            Val  := Integer ((Size + ONE_GB / 2) / ONE_GB);
            Unit := UNIT_GB'Access;

         elsif Size >= ONE_MB then
            Val  := Integer ((Size + ONE_MB / 2) / ONE_MB);
            Unit := UNIT_MB'Access;

         elsif Size >= ONE_KB then
            Val  := Integer ((Size + ONE_KB / 2) / ONE_KB);
            Unit := UNIT_KB'Access;

         else
            Val  := Integer (Size);
            Unit := UNIT_B'Access;
         end if;
         Values (1) := Util.Beans.Objects.To_Object (Val);
         ASF.Utils.Formats.Format (Bundle.Get (Unit.all), Values, Result);
         return Ada.Strings.Unbounded.To_String (Result);
      end;

   exception
      when E : others =>
         raise ASF.Converters.Invalid_Conversion with Ada.Exceptions.Exception_Message (E);
   end To_String;

   --  ------------------------------
   --  Convert the date string into an object for the specified component.
   --  If the string cannot be converted, the Invalid_Conversion exception should be raised.
   --  ------------------------------
   function To_Object (Convert   : in Size_Converter;
                       Context   : in ASF.Contexts.Faces.Faces_Context'Class;
                       Component : in ASF.Components.Base.UIComponent'Class;
                       Value     : in String) return Util.Beans.Objects.Object is
      pragma Unreferenced (Convert, Context, Value);
   begin
      Component.Log_Error ("Conversion of string to a size is not implemented");
      raise ASF.Converters.Invalid_Conversion with "Not implemented";
      return Util.Beans.Objects.Null_Object;
   end To_Object;

end ASF.Converters.Sizes;

Fix compilation warning

Fix compilation warning


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

with Wiki.Attributes;
with Wiki.Documents;
with Wiki.Nodes;
with Wiki.Strings;

--  == Filters ==
--  The <b>Wiki.Filters</b> package provides a simple filter framework that allows to plug
--  specific filters when a wiki document is parsed and processed.  The <tt>Filter_Type</tt>
--  implements the <tt>Document_Reader</tt> interface to catch all the wiki document operations
--  and it forwards the different calls to a next wiki document instance.  A filter can do some
--  operations while calls are made so that it can:
--
--  * Get the text content and filter it by looking at forbidden words in some dictionary,
--  * Ignore some formatting construct (for example to forbid the use of links),
--  * Verify and do some corrections on HTML content embedded in wiki text,
--  * Expand some plugins, specific links to complex content.
--
--  To implement a new filter, the <tt>Filter_Type</tt> type must be used as a base type
--  and some of the operations have to be overriden.  The default <tt>Filter_Type</tt> operations
--  just propagate the call to the attached wiki document instance (ie, a kind of pass
--  through filter).
--
package Wiki.Filters is

   pragma Preelaborate;

   use Ada.Strings.Wide_Wide_Unbounded;

   --  ------------------------------
   --  Filter type
   --  ------------------------------
   type Filter_Type is new Ada.Finalization.Limited_Controlled with private;
   type Filter_Type_Access is access all Filter_Type'Class;

   --  Add a simple node such as N_LINE_BREAK, N_HORIZONTAL_RULE or N_PARAGRAPH to the document.
   procedure Add_Node (Filter    : in out Filter_Type;
                       Document  : in out Wiki.Nodes.Document;
                       Kind      : in Wiki.Nodes.Simple_Node_Kind);

   --  Add a text content with the given format to the document.
   procedure Add_Text (Filter    : in out Filter_Type;
                       Document  : in out Wiki.Nodes.Document;
                       Text      : in Wiki.Strings.WString;
                       Format    : in Wiki.Nodes.Format_Map);

   --  Add a section header with the given level in the document.
   procedure Add_Header (Filter    : in out Filter_Type;
                         Document  : in out Wiki.Nodes.Document;
                         Header    : in Wiki.Strings.WString;
                         Level     : in Natural);

   --  Push a HTML node with the given tag to the document.
   procedure Push_Node (Filter     : in out Filter_Type;
                        Document   : in out Wiki.Nodes.Document;
                        Tag        : in Wiki.Nodes.Html_Tag_Type;
                        Attributes : in out Wiki.Attributes.Attribute_List_Type);

   --  Pop a HTML node with the given tag.
   procedure Pop_Node (Filter   : in out Filter_Type;
                       Document : in out Wiki.Nodes.Document;
                        Tag     : in Wiki.Nodes.Html_Tag_Type);

   --  Add a blockquote (<blockquote>).  The level indicates the blockquote nested level.
   --  The blockquote must be closed at the next header.
   procedure Add_Blockquote (Document : in out Filter_Type;
                             Level    : in Natural);

   --  Add a list item (<li>).  Close the previous paragraph and list item if any.
   --  The list item will be closed at the next list item, next paragraph or next header.
   procedure Add_List_Item (Document : in out Filter_Type;
                            Level    : in Positive;
                            Ordered  : in Boolean);

   --  Add a link.
   procedure Add_Link (Document : in out Filter_Type;
                       Name     : in Unbounded_Wide_Wide_String;
                       Link     : in Unbounded_Wide_Wide_String;
                       Language : in Unbounded_Wide_Wide_String;
                       Title    : in Unbounded_Wide_Wide_String);

   --  Add an image.
   procedure Add_Image (Document    : in out Filter_Type;
                        Link        : in Unbounded_Wide_Wide_String;
                        Alt         : in Unbounded_Wide_Wide_String;
                        Position    : in Unbounded_Wide_Wide_String;
                        Description : in Unbounded_Wide_Wide_String);

   --  Add a quote.
   procedure Add_Quote (Document : in out Filter_Type;
                        Quote    : in Unbounded_Wide_Wide_String;
                        Link     : in Unbounded_Wide_Wide_String;
                        Language : in Unbounded_Wide_Wide_String);

   --  Add a text block that is pre-formatted.
   procedure Add_Preformatted (Document : in out Filter_Type;
                               Text     : in Unbounded_Wide_Wide_String;
                               Format   : in Unbounded_Wide_Wide_String);

   --  Finish the document after complete wiki text has been parsed.
   procedure Finish (Document : in out Filter_Type);

private

   type Filter_Type is new Ada.Finalization.Limited_Controlled with record
      Next     : Filter_Type_Access;
   end record;

end Wiki.Filters;

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

with Wiki.Attributes;
with Wiki.Documents;
with Wiki.Nodes;
with Wiki.Strings;

--  == Filters ==
--  The <b>Wiki.Filters</b> package provides a simple filter framework that allows to plug
--  specific filters when a wiki document is parsed and processed.  The <tt>Filter_Type</tt>
--  implements the <tt>Document_Reader</tt> interface to catch all the wiki document operations
--  and it forwards the different calls to a next wiki document instance.  A filter can do some
--  operations while calls are made so that it can:
--
--  * Get the text content and filter it by looking at forbidden words in some dictionary,
--  * Ignore some formatting construct (for example to forbid the use of links),
--  * Verify and do some corrections on HTML content embedded in wiki text,
--  * Expand some plugins, specific links to complex content.
--
--  To implement a new filter, the <tt>Filter_Type</tt> type must be used as a base type
--  and some of the operations have to be overriden.  The default <tt>Filter_Type</tt> operations
--  just propagate the call to the attached wiki document instance (ie, a kind of pass
--  through filter).
--
package Wiki.Filters is

   pragma Preelaborate;

   use Ada.Strings.Wide_Wide_Unbounded;

   --  ------------------------------
   --  Filter type
   --  ------------------------------
   type Filter_Type is new Ada.Finalization.Limited_Controlled with private;
   type Filter_Type_Access is access all Filter_Type'Class;

   --  Add a simple node such as N_LINE_BREAK, N_HORIZONTAL_RULE or N_PARAGRAPH to the document.
   procedure Add_Node (Filter    : in out Filter_Type;
                       Document  : in out Wiki.Nodes.Document;
                       Kind      : in Wiki.Nodes.Simple_Node_Kind);

   --  Add a text content with the given format to the document.
   procedure Add_Text (Filter    : in out Filter_Type;
                       Document  : in out Wiki.Nodes.Document;
                       Text      : in Wiki.Strings.WString;
                       Format    : in Wiki.Nodes.Format_Map);

   --  Add a section header with the given level in the document.
   procedure Add_Header (Filter    : in out Filter_Type;
                         Document  : in out Wiki.Nodes.Document;
                         Header    : in Wiki.Strings.WString;
                         Level     : in Natural);

   --  Push a HTML node with the given tag to the document.
   procedure Push_Node (Filter     : in out Filter_Type;
                        Document   : in out Wiki.Nodes.Document;
                        Tag        : in Wiki.Nodes.Html_Tag_Type;
                        Attributes : in out Wiki.Attributes.Attribute_List_Type);

   --  Pop a HTML node with the given tag.
   procedure Pop_Node (Filter   : in out Filter_Type;
                       Document : in out Wiki.Nodes.Document;
                       Tag      : in Wiki.Nodes.Html_Tag_Type);

   --  Add a blockquote (<blockquote>).  The level indicates the blockquote nested level.
   --  The blockquote must be closed at the next header.
   procedure Add_Blockquote (Document : in out Filter_Type;
                             Level    : in Natural);

   --  Add a list item (<li>).  Close the previous paragraph and list item if any.
   --  The list item will be closed at the next list item, next paragraph or next header.
   procedure Add_List_Item (Document : in out Filter_Type;
                            Level    : in Positive;
                            Ordered  : in Boolean);

   --  Add a link.
   procedure Add_Link (Filter     : in out Filter_Type;
                       Document   : in out Wiki.Nodes.Document;
                       Name       : in Wiki.Strings.WString;
                       Attributes : in out Wiki.Attributes.Attribute_List_Type);

   --  Add an image.
   procedure Add_Image (Filter     : in out Filter_Type;
                        Document   : in out Wiki.Nodes.Document;
                        Name       : in Wiki.Strings.WString;
                        Attributes : in out Wiki.Attributes.Attribute_List_Type);

   --  Add a quote.
   procedure Add_Quote (Document : in out Filter_Type;
                        Quote    : in Unbounded_Wide_Wide_String;
                        Link     : in Unbounded_Wide_Wide_String;
                        Language : in Unbounded_Wide_Wide_String);

   --  Add a text block that is pre-formatted.
   procedure Add_Preformatted (Document : in out Filter_Type;
                               Text     : in Unbounded_Wide_Wide_String;
                               Format   : in Unbounded_Wide_Wide_String);

   --  Finish the document after complete wiki text has been parsed.
   procedure Finish (Document : in out Filter_Type);

private

   type Filter_Type is new Ada.Finalization.Limited_Controlled with record
      Next     : Filter_Type_Access;
   end record;

end Wiki.Filters;

Update the Add_Link and Add_Image operations for the new implementation


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

   pragma Preelaborate;

   LF : constant Wiki.Strings.WChar := Wiki.Strings.WChar'Val (16#0A#);
   CR : constant Wiki.Strings.WChar := Wiki.Strings.WChar'Val (16#0D#);
   HT : constant Wiki.Strings.WChar := Wiki.Strings.WChar'Val (16#09#);

   --  Returns True if the character is a space or tab.
   function Is_Space (C : in Wiki.Strings.WChar) return Boolean;

   --  Returns True if the character is a space, tab or a newline.
   function Is_Space_Or_Newline (C : in Wiki.Strings.WChar) return Boolean;

   --  Returns True if the character is a line terminator.
   function Is_Newline (C : in Wiki.Strings.WChar) return Boolean;

   --  Returns True if the text is a valid URL
   function Is_Url (Text : in Wiki.Strings.WString) return Boolean;

   --  Returns True if the extension part correspond to an image.
   --  Recognized extension are: .png, .gif, .jpg, .jpeg.
   --  The extension case is ignored.
   function Is_Image_Extension (Ext : in Wiki.Strings.WString) return Boolean;

   --  Given the current tag on the top of the stack and the new tag that will be pushed,
   --  decide whether the current tag must be closed or not.
   --  Returns True if the current tag must be closed.
   function Need_Close (Tag         : in Html_Tag;
                        Current_Tag : in Html_Tag) return Boolean;

end Wiki.Helpers;

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

   pragma Preelaborate;

   LF : constant Wiki.Strings.WChar := Wiki.Strings.WChar'Val (16#0A#);
   CR : constant Wiki.Strings.WChar := Wiki.Strings.WChar'Val (16#0D#);
   HT : constant Wiki.Strings.WChar := Wiki.Strings.WChar'Val (16#09#);

   --  Returns True if the character is a space or tab.
   function Is_Space (C : in Wiki.Strings.WChar) return Boolean;

   --  Returns True if the character is a space, tab or a newline.
   function Is_Space_Or_Newline (C : in Wiki.Strings.WChar) return Boolean;

   --  Returns True if the character is a line terminator.
   function Is_Newline (C : in Wiki.Strings.WChar) return Boolean;

   --  Returns True if the text is a valid URL
   function Is_Url (Text : in Wiki.Strings.WString) return Boolean;

   --  Returns True if the extension part correspond to an image.
   --  Recognized extension are: .png, .gif, .jpg, .jpeg.
   --  The extension case is ignored.
   function Is_Image_Extension (Ext : in Wiki.Strings.WString) return Boolean;

   --  Given the current tag on the top of the stack and the new tag that will be pushed,
   --  decide whether the current tag must be closed or not.
   --  Returns True if the current tag must be closed.
   function Need_Close (Tag         : in Html_Tag;
                        Current_Tag : in Html_Tag) return Boolean;

   --  Get the dimension represented by the string.  The string has one of the following
   --  formats:
   --    original           -> Width, Height := Natural'Last
   --    default            -> Width := 800, Height := 0
   --    upright            -> Width := 800, Height := 0
   --    <width>px          -> Width := <width>, Height := 0
   --    x<height>px        -> Width := 0, Height := <height>
   --    <width>x<height>px -> Width := <width>, Height := <height>
   procedure Get_Sizes (Dimension : in Wiki.Strings.WString;
                        Width     : out Natural;
                        Height    : out Natural);

end Wiki.Helpers;

Declare the Get_Sizes procedure

Declare the Get_Sizes procedure