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

with ADO.Sequences.Hilo;
with Ada.Unchecked_Deallocation;

--  The <b>ADO.Sessions.Factory</b> package defines the factory for creating
--  sessions.
package body ADO.Sessions.Factory is

   use ADO.Databases;

   --  ------------------------------
   --  Open a session
   --  ------------------------------
   procedure Open_Session (Factory  : in out Session_Factory;
                           Database : out Session) is
      S  : constant Session_Record_Access := new Session_Record;
      DB : constant Master_Connection'Class := Factory.Source.Get_Connection;
   begin
      S.Database := Master_Connection (DB);
      S.Entities := Factory.Entities;
      Database.Impl := S;
   end Open_Session;

   --  ------------------------------
   --  Get a read-only session from the factory.
   --  ------------------------------
   function Get_Session (Factory : in Session_Factory) return Session is
      R  : Session;
      S  : constant Session_Record_Access := new Session_Record;
      DB : constant Master_Connection'Class := Factory.Source.Get_Connection;
   begin
      S.Database := Master_Connection (DB);
      S.Entities := Factory.Entities;
      R.Impl := S;
      return R;
   end Get_Session;

   --  ------------------------------
   --  Get a read-only session from the session proxy.
   --  If the session has been invalidated, raise the SESSION_EXPIRED exception.
   --  ------------------------------
   function Get_Session (Proxy : in Session_Proxy_Access) return Session is
      R : Session;
   begin
      if Proxy = null then
         raise ADO.Objects.SESSION_EXPIRED;
      end if;
      if Proxy.Session = null then
         raise ADO.Objects.SESSION_EXPIRED;
      end if;
      R.Impl := Proxy.Session;
      R.Impl.Counter := R.Impl.Counter + 1;
      return R;
   end Get_Session;

   --  ------------------------------
   --  Get a read-only session from the session proxy.
   --  If the session has been invalidated, raise the SESSION_EXPIRED exception.
   --  ------------------------------
   function Get_Session (Proxy : in Session_Record_Access) return Session is
      R : Session;
   begin
      if Proxy = null then
         raise ADO.Objects.SESSION_EXPIRED;
      end if;
--        if Proxy.Session = null then
--           raise ADO.Objects.SESSION_EXPIRED;
--        end if;
      R.Impl := Proxy;
      R.Impl.Counter := R.Impl.Counter + 1;
      return R;
   end Get_Session;

   --  ------------------------------
   --  Get a read-write session from the factory.
   --  ------------------------------
   function Get_Master_Session (Factory : in Session_Factory) return Master_Session is
      R  : Master_Session;
      S  : constant Session_Record_Access   := new Session_Record;
      DB : constant Master_Connection'Class := Factory.Source.Get_Connection;
   begin
      S.Database := Master_Connection (DB);
      S.Entities := Factory.Entities;
      R.Impl := S;
      R.Sequences := Factory.Sequences;
      return R;
   end Get_Master_Session;

   --  ------------------------------
   --  Open a session
   --  ------------------------------
   procedure Open_Session (Factory : in Session_Factory;
                           Database : out Master_Session) is
   begin
      null;
   end Open_Session;

   --  ------------------------------
   --  Initialize the sequence factory associated with the session factory.
   --  ------------------------------
   procedure Initialize_Sequences (Factory : in out Session_Factory) is
      use ADO.Sequences;
   begin
      Factory.Sequences := new ADO.Sequences.Factory;
      Set_Default_Generator (Factory.Sequences.all,
                             ADO.Sequences.Hilo.Create_HiLo_Generator'Access,
                             Factory'Unrestricted_Access);
   end Initialize_Sequences;

   --  ------------------------------
   --  Create the session factory to connect to the database represented
   --  by the data source.
   --  ------------------------------
   procedure Create (Factory : out Session_Factory;
                     Source  : in ADO.Databases.DataSource) is
   begin
      Factory.Source := Source;
      Factory.Entities := Factory.Entity_Cache'Unchecked_Access;
      Initialize_Sequences (Factory);

      declare
         S : Session := Factory.Get_Session;
      begin
         ADO.Schemas.Entities.Initialize (Factory.Entity_Cache, S);
      end;
   end Create;

   --  ------------------------------
   --  Create the session factory to connect to the database identified
   --  by the URI.
   --  ------------------------------
   procedure Create (Factory : out Session_Factory;
                     URI     : in String) is
   begin
      Factory.Source.Set_Connection (URI);
      Factory.Entities := Factory.Entity_Cache'Unchecked_Access;
      Initialize_Sequences (Factory);

      declare
         S : Session := Factory.Get_Session;
      begin
         ADO.Schemas.Entities.Initialize (Factory.Entity_Cache, S);
      end;
   end Create;

   --  ------------------------------
   --  Finalize and release the factory
   --  ------------------------------
   overriding
   procedure Finalize (Factory : in out Session_Factory) is

      procedure Free is new
        Ada.Unchecked_Deallocation (Object => ADO.Sequences.Factory,
                                    Name   => ADO.Sequences.Factory_Access);

      Seq : ADO.Sequences.Factory_Access;
   begin
      if Factory.Sequences /= null then
         Seq := Factory.Sequences.all'Access;
         Free (Seq);
         Factory.Sequences := null;
      end if;
   end Finalize;

end ADO.Sessions.Factory;

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

with ADO.Sequences.Hilo;
with Ada.Unchecked_Deallocation;

--  The <b>ADO.Sessions.Factory</b> package defines the factory for creating
--  sessions.
package body ADO.Sessions.Factory is

   use ADO.Databases;

   --  ------------------------------
   --  Open a session
   --  ------------------------------
   procedure Open_Session (Factory  : in out Session_Factory;
                           Database : out Session) is
      S  : constant Session_Record_Access := new Session_Record;
      DB : constant Master_Connection'Class := Factory.Source.Get_Connection;
   begin
      S.Database := Master_Connection (DB);
      S.Entities := Factory.Entities;
      Database.Impl := S;
   end Open_Session;

   --  ------------------------------
   --  Get a read-only session from the factory.
   --  ------------------------------
   function Get_Session (Factory : in Session_Factory) return Session is
      R  : Session;
      S  : constant Session_Record_Access := new Session_Record;
      DB : constant Master_Connection'Class := Factory.Source.Get_Connection;
   begin
      S.Database := Master_Connection (DB);
      S.Entities := Factory.Entities;
      R.Impl := S;
      return R;
   end Get_Session;

   --  ------------------------------
   --  Get a read-only session from the session proxy.
   --  If the session has been invalidated, raise the SESSION_EXPIRED exception.
   --  ------------------------------
   function Get_Session (Proxy : in Session_Proxy_Access) return Session is
      R : Session;
   begin
      if Proxy = null then
         raise ADO.Objects.SESSION_EXPIRED;
      end if;
      if Proxy.Session = null then
         raise ADO.Objects.SESSION_EXPIRED;
      end if;
      R.Impl := Proxy.Session;
      R.Impl.Counter := R.Impl.Counter + 1;
      return R;
   end Get_Session;

   --  ------------------------------
   --  Get a read-only session from the session proxy.
   --  If the session has been invalidated, raise the SESSION_EXPIRED exception.
   --  ------------------------------
   function Get_Session (Proxy : in Session_Record_Access) return Session is
      R : Session;
   begin
      if Proxy = null then
         raise ADO.Objects.SESSION_EXPIRED;
      end if;
--        if Proxy.Session = null then
--           raise ADO.Objects.SESSION_EXPIRED;
--        end if;
      R.Impl := Proxy;
      R.Impl.Counter := R.Impl.Counter + 1;
      return R;
   end Get_Session;

   --  ------------------------------
   --  Get a read-write session from the factory.
   --  ------------------------------
   function Get_Master_Session (Factory : in Session_Factory) return Master_Session is
      R  : Master_Session;
      S  : constant Session_Record_Access   := new Session_Record;
      DB : constant Master_Connection'Class := Factory.Source.Get_Connection;
   begin
      S.Database := Master_Connection (DB);
      S.Entities := Factory.Entities;
      R.Impl := S;
      R.Sequences := Factory.Sequences;
      return R;
   end Get_Master_Session;

   --  ------------------------------
   --  Open a session
   --  ------------------------------
   procedure Open_Session (Factory : in Session_Factory;
                           Database : out Master_Session) is
   begin
      null;
   end Open_Session;

   --  ------------------------------
   --  Initialize the sequence factory associated with the session factory.
   --  ------------------------------
   procedure Initialize_Sequences (Factory : in out Session_Factory) is
      use ADO.Sequences;
   begin
      Factory.Sequences := new ADO.Sequences.Factory;
      Set_Default_Generator (Factory.Sequences.all,
                             ADO.Sequences.Hilo.Create_HiLo_Generator'Access,
                             Factory'Unrestricted_Access);
   end Initialize_Sequences;

   --  ------------------------------
   --  Create the session factory to connect to the database represented
   --  by the data source.
   --  ------------------------------
   procedure Create (Factory : out Session_Factory;
                     Source  : in ADO.Databases.DataSource) is
   begin
      Factory.Source := Source;
      Factory.Entities := Factory.Entity_Cache'Unchecked_Access;
      Initialize_Sequences (Factory);

      if Factory.Source.Get_Database /= "" then
         declare
            S : Session := Factory.Get_Session;
         begin
            ADO.Schemas.Entities.Initialize (Factory.Entity_Cache, S);
         end;
      end if;
   end Create;

   --  ------------------------------
   --  Create the session factory to connect to the database identified
   --  by the URI.
   --  ------------------------------
   procedure Create (Factory : out Session_Factory;
                     URI     : in String) is
   begin
      Factory.Source.Set_Connection (URI);
      Factory.Entities := Factory.Entity_Cache'Unchecked_Access;
      Initialize_Sequences (Factory);

      if Factory.Source.Get_Database /= "" then
         declare
            S : Session := Factory.Get_Session;
         begin
            ADO.Schemas.Entities.Initialize (Factory.Entity_Cache, S);
         end;
      end if;
   end Create;

   --  ------------------------------
   --  Finalize and release the factory
   --  ------------------------------
   overriding
   procedure Finalize (Factory : in out Session_Factory) is

      procedure Free is new
        Ada.Unchecked_Deallocation (Object => ADO.Sequences.Factory,
                                    Name   => ADO.Sequences.Factory_Access);

      Seq : ADO.Sequences.Factory_Access;
   begin
      if Factory.Sequences /= null then
         Seq := Factory.Sequences.all'Access;
         Free (Seq);
         Factory.Sequences := null;
      end if;
   end Finalize;

end ADO.Sessions.Factory;

Load the database entities only if we have a database


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

with Util.Strings.Transforms;
with GNAT.MD5;

with ASF.Utils;
with ASF.Contexts.Writer;
package body ASF.Components.Widgets.Gravatars is

   IMAGE_ATTRIBUTE_NAMES : Util.Strings.String_Set.Set;

   --  ------------------------------
   --  Given an Email address, return the Gravatar link to the user image.
   --  (See http://en.gravatar.com/site/implement/hash/ and
   --  http://en.gravatar.com/site/implement/images/)
   --  ------------------------------
   function Get_Link (Email  : in String;
                      Secure : in Boolean := False) return String is
      E : constant String := Util.Strings.Transforms.To_Lower_Case (Email);
      C : constant GNAT.MD5.Message_Digest := GNAT.MD5.Digest (E);
   begin
      if Secure then
         return "https://secure.gravatar.com/avatar/" & C;
      else
         return "http://www.gravatar.com/avatar/" & C;
      end if;
   end Get_Link;

   --  ------------------------------
   --  Render an image with the source link created from an email address to the Gravatars service.
   --  ------------------------------
   overriding
   procedure Encode_Begin (UI      : in UIGravatar;
                           Context : in out ASF.Contexts.Faces.Faces_Context'Class) is
      Writer   : constant Contexts.Writer.Response_Writer_Access := Context.Get_Response_Writer;
   begin
      if UI.Is_Rendered (Context) then
         Writer.Start_Element ("img");
         UI.Render_Attributes (Context, IMAGE_ATTRIBUTE_NAMES, Writer);
         declare
            Email   : constant String := UI.Get_Attribute ("email", Context, "");
            Size    : constant Natural := UI.Get_Attribute ("size", Context, 60);
            Default : constant String := UI.Get_Attribute ("default", Context, "identicon");
            Secure  : constant Boolean := UI.Get_Attribute ("secure", Context, False);
            D       : constant String := Util.Strings.Image (Size);
         begin
            Writer.Write_Attribute ("width", D);
            Writer.Write_Attribute ("height", D);
            Writer.Write_Attribute ("src", Get_Link (Email, Secure)
                                    & "?d=" & Default & "&s=" & D);
         end;
         Writer.End_Element ("img");
      end if;
   end Encode_Begin;

begin
   Utils.Set_Text_Attributes (IMAGE_ATTRIBUTE_NAMES);
end ASF.Components.Widgets.Gravatars;

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

with Util.Strings.Transforms;
with GNAT.MD5;

with ASF.Utils;
with ASF.Contexts.Writer;
package body ASF.Components.Widgets.Gravatars is

   IMAGE_ATTRIBUTE_NAMES : Util.Strings.String_Set.Set;

   --  ------------------------------
   --  Given an Email address, return the Gravatar link to the user image.
   --  (See http://en.gravatar.com/site/implement/hash/ and
   --  http://en.gravatar.com/site/implement/images/)
   --  ------------------------------
   function Get_Link (Email  : in String;
                      Secure : in Boolean := False) return String is
      E : constant String := Util.Strings.Transforms.To_Lower_Case (Email);
      C : constant GNAT.MD5.Message_Digest := GNAT.MD5.Digest (E);
   begin
      if Secure then
         return "https://secure.gravatar.com/avatar/" & C;
      else
         return "http://www.gravatar.com/avatar/" & C;
      end if;
   end Get_Link;

   --  ------------------------------
   --  Render an image with the source link created from an email address to the Gravatars service.
   --  ------------------------------
   overriding
   procedure Encode_Begin (UI      : in UIGravatar;
                           Context : in out ASF.Contexts.Faces.Faces_Context'Class) is
      Writer   : constant Contexts.Writer.Response_Writer_Access := Context.Get_Response_Writer;
   begin
      if UI.Is_Rendered (Context) then
         Writer.Start_Element ("img");
         UI.Render_Attributes (Context, IMAGE_ATTRIBUTE_NAMES, Writer);
         declare
            Email   : constant String := UI.Get_Attribute ("email", Context, "");
            Size    : Natural := UI.Get_Attribute ("size", Context, 80);
            Default : constant String := UI.Get_Attribute ("default", Context, "identicon");
            Secure  : constant Boolean := UI.Get_Attribute ("secure", Context, False);
            D       : constant String := Util.Strings.Image (Size);
            Alt     : constant String := UI.Get_Attribute ("alt", Context, "");
         begin
            if Size < 0 or Size > 2048 then
               Size := 80;
            end if;
            Writer.Write_Attribute ("width", D);
            Writer.Write_Attribute ("height", D);
            if Alt'Length > 0 then
               Writer.Write_Attribute ("alt", Alt);
            else
               Writer.Write_Attribute ("alt", Email);
            end if;
            Writer.Write_Attribute ("src", Get_Link (Email, Secure)
                                    & "?d=" & Default & "&s=" & D);
         end;
         Writer.End_Element ("img");
      end if;
   end Encode_Begin;

begin
   Utils.Set_Text_Attributes (IMAGE_ATTRIBUTE_NAMES);
end ASF.Components.Widgets.Gravatars;

Add the 'alt' attribute on the gravatar image Make sure the image size is in the 1 .. 2048 range, ignore the size attribute if it is not valid


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

   --  use Util.Log;
   use type Util.Log.Loggers.Logger_Access;

   --  The logger'
   Log : aliased constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Util.Serialize.IO",
                                                                              Util.Log.WARN_LEVEL);
   procedure Write_Attribute (Stream : in out Output_Stream'Class;
                              Name   : in String;
                              Value  : in Ada.Strings.Unbounded.Unbounded_String) is
   begin
      Stream.Write_Attribute (Name, Ada.Strings.Unbounded.To_String (Value));
   end Write_Attribute;

   procedure Write_Entity (Stream : in out Output_Stream'Class;
                           Name   : in String;
                           Value  : in Ada.Strings.Unbounded.Unbounded_String) is
   begin
      Stream.Write_Entity (Name, Ada.Strings.Unbounded.To_String (Value));
   end Write_Entity;

   --  ------------------------------
   --  Read the file and parse it using the JSON parser.
   --  ------------------------------
   procedure Parse (Handler : in out Parser;
                    File    : in String;
                    Sink    : in out Reader'Class) is
      Stream     : aliased Util.Streams.Files.File_Stream;
      Buffer     : Util.Streams.Buffered.Buffered_Stream;
   begin
      if Handler.Error_Logger = null then
         Handler.Error_Logger := Log'Access;
      end if;
      Handler.Error_Logger.Info ("Reading file {0}", File);

      Handler.File := Ada.Strings.Unbounded.To_Unbounded_String (File);
      Buffer.Initialize (Output => null,
                         Input  => Stream'Unchecked_Access,
                         Size   => 1024);
      Stream.Open (Mode => Ada.Streams.Stream_IO.In_File, Name => File);
      --  Context_Stack.Clear (Handler.Stack);
      Sink.Start_Document;
      Parser'Class (Handler).Parse (Buffer, Sink);

   exception
--      when Util.Serialize.Mappers.Field_Fatal_Error =>
--         null;

      when Ada.IO_Exceptions.Name_Error =>
         Parser'Class (Handler).Error ("File '" & File & "' does not exist.");

      when E : others =>
         if not Handler.Error_Flag then
            Parser'Class (Handler).Error ("Exception " & Ada.Exceptions.Exception_Name (E));
         end if;
   end Parse;

   --  ------------------------------
   --  Parse the content string.
   --  ------------------------------
   procedure Parse_String (Handler : in out Parser;
                           Content : in String;
                           Sink    : in out Reader'Class) is
      Stream : aliased Util.Streams.Buffered.Buffered_Stream;
   begin
      if Handler.Error_Logger = null then
         Handler.Error_Logger := Log'Access;
      end if;
      Handler.File := Ada.Strings.Unbounded.To_Unbounded_String ("<inline>");
      Stream.Initialize (Content  => Content);
      --  Context_Stack.Clear (Handler.Stack);
      Sink.Start_Document;
      Parser'Class (Handler).Parse (Stream, Sink);

   exception
--      when Util.Serialize.Mappers.Field_Fatal_Error =>
--         null;

      when E : others =>
         if not Handler.Error_Flag then
            Parser'Class (Handler).Error ("Exception " & Ada.Exceptions.Exception_Name (E));
         end if;

   end Parse_String;

   --  ------------------------------
   --  Returns true if the Parse operation detected at least one error.
   --  ------------------------------
   function Has_Error (Handler : in Parser) return Boolean is
   begin
      return Handler.Error_Flag;
   end Has_Error;

   --  ------------------------------
   --  Set the error logger to report messages while parsing and reading the input file.
   --  ------------------------------
   procedure Set_Logger (Handler : in out Parser;
                         Logger  : in Util.Log.Loggers.Logger_Access) is
   begin
      Handler.Error_Logger := Logger;
   end Set_Logger;

   --  ------------------------------
   --  Get the current location (file and line) to report an error message.
   --  ------------------------------
   function Get_Location (Handler : in Parser) return String is
   begin
      return Ada.Strings.Unbounded.To_String (Handler.File);
   end Get_Location;

   --  ------------------------------
   --  Report an error while parsing the input stream.  The error message will be reported
   --  on the logger associated with the parser.  The parser will be set as in error so that
   --  the Has_Error function will return True after parsing the whole file.
   --  ------------------------------
   procedure Error (Handler : in out Parser;
                    Message : in String) is
   begin
      Handler.Error_Logger.Error ("{0}: {1}",
                                  Parser'Class (Handler).Get_Location,
                                  Message);
      Handler.Error_Flag := True;
   end Error;

end Util.Serialize.IO;

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

   --  use Util.Log;
   use type Util.Log.Loggers.Logger_Access;

   --  The logger'
   Log : aliased constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Util.Serialize.IO",
                                                                              Util.Log.WARN_LEVEL);
   procedure Write_Attribute (Stream : in out Output_Stream'Class;
                              Name   : in String;
                              Value  : in Ada.Strings.Unbounded.Unbounded_String) is
   begin
      Stream.Write_Attribute (Name, Ada.Strings.Unbounded.To_String (Value));
   end Write_Attribute;

   procedure Write_Entity (Stream : in out Output_Stream'Class;
                           Name   : in String;
                           Value  : in Ada.Strings.Unbounded.Unbounded_String) is
   begin
      Stream.Write_Entity (Name, Ada.Strings.Unbounded.To_String (Value));
   end Write_Entity;

   --  ------------------------------
   --  Read the file and parse it using the JSON parser.
   --  ------------------------------
   procedure Parse (Handler : in out Parser;
                    File    : in String;
                    Sink    : in out Reader'Class) is
      Stream     : aliased Util.Streams.Files.File_Stream;
      Buffer     : Util.Streams.Buffered.Buffered_Stream;
   begin
      if Handler.Error_Logger = null then
         Handler.Error_Logger := Log'Access;
      end if;
      Handler.Error_Logger.Info ("Reading file {0}", File);

      Handler.File := Ada.Strings.Unbounded.To_Unbounded_String (File);
      Buffer.Initialize (Output => null,
                         Input  => Stream'Unchecked_Access,
                         Size   => 1024);
      Stream.Open (Mode => Ada.Streams.Stream_IO.In_File, Name => File);
      Sink.Start_Document;
      Parser'Class (Handler).Parse (Buffer, Sink);

   exception
--      when Util.Serialize.Mappers.Field_Fatal_Error =>
--         null;

      when Ada.IO_Exceptions.Name_Error =>
         Parser'Class (Handler).Error ("File '" & File & "' does not exist.");

      when E : others =>
         if not Handler.Error_Flag then
            Parser'Class (Handler).Error ("Exception " & Ada.Exceptions.Exception_Name (E));
         end if;
   end Parse;

   --  ------------------------------
   --  Parse the content string.
   --  ------------------------------
   procedure Parse_String (Handler : in out Parser;
                           Content : in String;
                           Sink    : in out Reader'Class) is
      Stream : aliased Util.Streams.Buffered.Buffered_Stream;
   begin
      if Handler.Error_Logger = null then
         Handler.Error_Logger := Log'Access;
      end if;
      Handler.File := Ada.Strings.Unbounded.To_Unbounded_String ("<inline>");
      Stream.Initialize (Content  => Content);
      Sink.Start_Document;
      Parser'Class (Handler).Parse (Stream, Sink);

   exception
--      when Util.Serialize.Mappers.Field_Fatal_Error =>
--         null;

      when E : others =>
         if not Handler.Error_Flag then
            Parser'Class (Handler).Error ("Exception " & Ada.Exceptions.Exception_Name (E));
         end if;

   end Parse_String;

   --  ------------------------------
   --  Returns true if the Parse operation detected at least one error.
   --  ------------------------------
   function Has_Error (Handler : in Parser) return Boolean is
   begin
      return Handler.Error_Flag;
   end Has_Error;

   --  ------------------------------
   --  Set the error logger to report messages while parsing and reading the input file.
   --  ------------------------------
   procedure Set_Logger (Handler : in out Parser;
                         Logger  : in Util.Log.Loggers.Logger_Access) is
   begin
      Handler.Error_Logger := Logger;
   end Set_Logger;

   --  ------------------------------
   --  Get the current location (file and line) to report an error message.
   --  ------------------------------
   function Get_Location (Handler : in Parser) return String is
   begin
      return Ada.Strings.Unbounded.To_String (Handler.File);
   end Get_Location;

   --  ------------------------------
   --  Report an error while parsing the input stream.  The error message will be reported
   --  on the logger associated with the parser.  The parser will be set as in error so that
   --  the Has_Error function will return True after parsing the whole file.
   --  ------------------------------
   procedure Error (Handler : in out Parser;
                    Message : in String) is
   begin
      Handler.Error_Logger.Error ("{0}: {1}",
                                  Parser'Class (Handler).Get_Location,
                                  Message);
      Handler.Error_Flag := True;
   end Error;

end Util.Serialize.IO;

Remove unused commented code

Remove unused commented code


-- Copyright 2017 Jeff Foley. All rights reserved.
-- Use of this source code is governed by Apache 2 LICENSE that can be found in the LICENSE file.

local url = require("url")

name = "Yahoo"
type = "scrape"

function start()
    setratelimit(1)
end

function vertical(ctx, domain)
    for i=0,10 do
        local ok = scrape(ctx, {['url']=buildurl(domain, i)})
        if not ok then
            break
        end

        checkratelimit()
    end
end

function buildurl(domain, pagenum)
    local next = tostring((pagenum * 10) + 1)
    local query = "site:" .. domain .. " -domain:www." .. domain
    local params = {
        p=query,
		b=next,
        pz="10",
        bct="0",
        xargs="0",
    }

    return "https://search.yahoo.com/search?" .. url.build_query_string(params)
end

-- Copyright 2017 Jeff Foley. All rights reserved.
-- Use of this source code is governed by Apache 2 LICENSE that can be found in the LICENSE file.

local url = require("url")

name = "Yahoo"
type = "scrape"

function start()
    setratelimit(1)
end

function vertical(ctx, domain)
    for i=1,201,10 do
        local ok = scrape(ctx, {['url']=buildurl(domain, i)})
        if not ok then
            break
        end

        checkratelimit()
    end
end

function buildurl(domain, pagenum)
    local next = tostring(pagenum)
    local query = "site:" .. domain .. " -domain:www." .. domain
    local params = {
        p=query,
        b=next,
        pz="10",
        bct="0",
        xargs="0",
    }

    return "https://search.yahoo.com/search?" .. url.build_query_string(params)
end

Clean code

Clean code


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

with Util.Test_Caller;

with Util.Strings.Transforms;
with Util.Http.Tools;
with Util.Strings;
with Util.Log.Loggers;

package body Util.Http.Clients.Tests is

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Util.Http.Clients.Tests");

   package body Http_Tests is
      package Caller is new Util.Test_Caller (Http_Test, "Http-" & NAME);

      procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
      begin
         Caller.Add_Test (Suite, "Test Util.Http.Clients." & NAME & ".Get",
                          Test_Http_Get'Access);
         Caller.Add_Test (Suite, "Test Util.Http.Clients." & NAME & ".Post",
                          Test_Http_Post'Access);
         Caller.Add_Test (Suite, "Test Util.Http.Clients." & NAME & ".Put",
                          Test_Http_Put'Access);
         Caller.Add_Test (Suite, "Test Util.Http.Clients." & NAME & ".Delete",
                          Test_Http_Delete'Access);
         Caller.Add_Test (Suite, "Test Util.Http.Clients." & NAME & ".Get (timeout)",
                          Test_Http_Timeout'Access);
      end Add_Tests;

      overriding
      procedure Set_Up (T : in out Http_Test) is
      begin
         Test (T).Set_Up;
         Register;
      end Set_Up;

   end Http_Tests;

   overriding
   procedure Set_Up (T : in out Test) is
   begin
      Log.Info ("Starting test server");
      T.Server := new Test_Server;
      T.Server.Start;
   end Set_Up;

   overriding
   procedure Tear_Down (T : in out Test) is
      procedure Free is
         new Ada.Unchecked_Deallocation (Object => Test_Server'Class,
                                         Name   => Test_Server_Access);
   begin
      if T.Server /= null then
         Log.Info ("Stopping test server");
         T.Server.Stop;
         Free (T.Server);
         T.Server := null;
      end if;
   end Tear_Down;

   --  ------------------------------
   --  Process the line received by the server.
   --  ------------------------------
   overriding
   procedure Process_Line (Into   : in out Test_Server;
                           Line   : in Ada.Strings.Unbounded.Unbounded_String;
                           Stream : in out Util.Streams.Texts.Reader_Stream'Class;
                           Client : in out Util.Streams.Sockets.Socket_Stream'Class) is
      L   : constant String := Ada.Strings.Unbounded.To_String (Line);
      Pos : Natural := Util.Strings.Index (L, ' ');
   begin
      if Pos > 0 and Into.Method = UNKNOWN then
         if L (L'First .. Pos - 1) = "GET" then
            Into.Method := GET;
         elsif L (L'First .. Pos - 1) = "POST" then
            Into.Method := POST;
         elsif L (L'First .. Pos - 1) = "PUT" then
            Into.Method := PUT;
         elsif L (L'First .. Pos - 1) = "DELETE" then
            Into.Method := DELETE;
         else
            Into.Method := UNKNOWN;
         end if;
      end if;

      Pos := Util.Strings.Index (L, ':');
      if Pos > 0 then
         if L (L'First .. Pos) = "Content-Type:" then
            Into.Content_Type
              := Ada.Strings.Unbounded.To_Unbounded_String (L (Pos + 2 .. L'Last - 2));
         elsif L (L'First .. Pos) = "Content-Length:" then
            Into.Length := Natural'Value (L (Pos + 1 .. L'Last - 2));

         end if;
      end if;

      --  Don't answer if we check the timeout.
      if Into.Test_Timeout then
         return;
      end if;
      if L'Length = 2 and then Into.Length > 0 then
         for I in 1 .. Into.Length loop
            declare
               C : Character;
            begin
               Stream.Read (C);
               Ada.Strings.Unbounded.Append (Into.Result, C);
            end;
         end loop;
         declare
            Output : Util.Streams.Texts.Print_Stream;
         begin
            Output.Initialize (Client'Unchecked_Access);
            Output.Write ("HTTP/1.1 200 Found" & ASCII.CR & ASCII.LF);
            Output.Write ("Content-Length: 4" & ASCII.CR & ASCII.LF);
            Output.Write (ASCII.CR & ASCII.LF);
            Output.Write ("OK" & ASCII.CR & ASCII.LF);
            Output.Flush;
         end;
      elsif L'Length = 2 then
         declare
            Output : Util.Streams.Texts.Print_Stream;
         begin
            Output.Initialize (Client'Unchecked_Access);
            Output.Write ("HTTP/1.1 204 No Content" & ASCII.CR & ASCII.LF);
            Output.Write (ASCII.CR & ASCII.LF);
            Output.Flush;
         end;
      end if;
      Log.Info ("Received: {0}", L);
   end Process_Line;

   --  ------------------------------
   --  Get the test server base URI.
   --  ------------------------------
   function Get_Uri (T : in Test) return String is

   begin
      return "http://" & T.Server.Get_Host & ":" & Util.Strings.Image (T.Server.Get_Port);
   end Get_Uri;

   --  ------------------------------
   --  Test the http Get operation.
   --  ------------------------------
   procedure Test_Http_Get (T : in out Test) is
      Request : Client;
      Reply   : Response;
   begin
      Request.Get ("http://www.google.com", Reply);
      T.Assert (Reply.Get_Status = 200 or Reply.Get_Status = 302,
                "Get status is invalid: " & Natural'Image (Reply.Get_Status));

      Util.Http.Tools.Save_Response (Util.Tests.Get_Test_Path ("http_get.txt"), Reply, True);

      --  Check the content.
      declare
         Content : constant String := Util.Strings.Transforms.To_Lower_Case (Reply.Get_Body);
      begin
         Util.Tests.Assert_Matches (T, ".*html.*", Content, "Invalid GET content");
      end;

      T.Assert (Reply.Contains_Header ("Content-Type"), "Header Content-Type not found");
      T.Assert (not Reply.Contains_Header ("Content-Type-Invalid-Missing"),
                "Some invalid header found");

      --  Check one header.
      declare
         Content : constant String := Reply.Get_Header ("Content-Type");
      begin
         T.Assert (Content'Length > 0, "Empty Content-Type header");
         Util.Tests.Assert_Matches (T, ".*text/html.*", Content, "Invalid content type");
      end;
   end Test_Http_Get;

   --  ------------------------------
   --  Test the http POST operation.
   --  ------------------------------
   procedure Test_Http_Post (T : in out Test) is
      Request : Client;
      Reply   : Response;
      Uri     : constant String := T.Get_Uri;
   begin
      Log.Info ("Post on " & Uri);

      T.Server.Method := UNKNOWN;
      Request.Post (Uri & "/post",
                    "p1=1", Reply);

      T.Assert (T.Server.Method = POST, "Invalid method received by server");
      Util.Tests.Assert_Equals (T, "application/x-www-form-urlencoded", T.Server.Content_Type,
                                "Invalid content type received by server");
      Util.Tests.Assert_Equals (T, "OK" & ASCII.CR & ASCII.LF, Reply.Get_Body, "Invalid response");
      Util.Http.Tools.Save_Response (Util.Tests.Get_Test_Path ("http_post.txt"), Reply, True);

   end Test_Http_Post;

   --  ------------------------------
   --  Test the http PUT operation.
   --  ------------------------------
   procedure Test_Http_Put (T : in out Test) is
      Request : Client;
      Reply   : Response;
      Uri     : constant String := T.Get_Uri;
   begin
      Log.Info ("Put on " & Uri);

      T.Server.Method := UNKNOWN;
      Request.Add_Header ("Content-Type", "application/x-www-form-urlencoded");
      T.Assert (Request.Contains_Header ("Content-Type"), "Missing Content-Type");
      Request.Put (Uri & "/put",
                   "p1=1", Reply);

      T.Assert (T.Server.Method = PUT, "Invalid method received by server");
      Util.Tests.Assert_Equals (T, "application/x-www-form-urlencoded", T.Server.Content_Type,
                                "Invalid content type received by server");
      Util.Tests.Assert_Equals (T, "OK" & ASCII.CR & ASCII.LF, Reply.Get_Body, "Invalid response");
      Util.Http.Tools.Save_Response (Util.Tests.Get_Test_Path ("http_put.txt"), Reply, True);

   end Test_Http_Put;

   --  ------------------------------
   --  Test the http DELETE operation.
   --  ------------------------------
   procedure Test_Http_Delete (T : in out Test) is
      Request : Client;
      Reply   : Response;
      Uri     : constant String := T.Get_Uri;
   begin
      Log.Info ("Delete on " & Uri);

      T.Server.Method := UNKNOWN;
      Request.Add_Header ("Content-Type", "application/x-www-form-urlencoded");
      T.Assert (Request.Contains_Header ("Content-Type"), "Missing Content-Type");
      Request.Delete (Uri & "/delete", Reply);

      T.Assert (T.Server.Method = DELETE, "Invalid method received by server");
      Util.Tests.Assert_Equals (T, "application/x-www-form-urlencoded", T.Server.Content_Type,
                                "Invalid content type received by server");
      Util.Tests.Assert_Equals (T, "", Reply.Get_Body, "Invalid response");
      Util.Tests.Assert_Equals (T, 204, Reply.Get_Status, "Invalid status response");

   end Test_Http_Delete;

   --  ------------------------------
   --  Test the http timeout.
   --  ------------------------------
   procedure Test_Http_Timeout (T : in out Test) is
      Request : Client;
      Reply   : Response;
      Uri     : constant String := T.Get_Uri;
   begin
      Log.Info ("Timeout on " & Uri);

      T.Server.Test_Timeout := True;
      T.Server.Method := UNKNOWN;
      Request.Set_Timeout (0.5);
      begin
         Request.Get (Uri & "/timeout", Reply);
         T.Fail ("No Connection_Error exception raised");

      exception
         when Connection_Error =>
            null;
      end;

   end Test_Http_Timeout;

end Util.Http.Clients.Tests;

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

with Util.Test_Caller;

with Util.Strings.Transforms;
with Util.Http.Tools;
with Util.Strings;
with Util.Log.Loggers;

package body Util.Http.Clients.Tests is

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Util.Http.Clients.Tests");

   package body Http_Tests is
      package Caller is new Util.Test_Caller (Http_Test, "Http-" & NAME);

      procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
      begin
         Caller.Add_Test (Suite, "Test Util.Http.Clients." & NAME & ".Get",
                          Test_Http_Get'Access);
         Caller.Add_Test (Suite, "Test Util.Http.Clients." & NAME & ".Post",
                          Test_Http_Post'Access);
         Caller.Add_Test (Suite, "Test Util.Http.Clients." & NAME & ".Put",
                          Test_Http_Put'Access);
         Caller.Add_Test (Suite, "Test Util.Http.Clients." & NAME & ".Delete",
                          Test_Http_Delete'Access);
         Caller.Add_Test (Suite, "Test Util.Http.Clients." & NAME & ".Get (timeout)",
                          Test_Http_Timeout'Access);
      end Add_Tests;

      overriding
      procedure Set_Up (T : in out Http_Test) is
      begin
         Test (T).Set_Up;
         Register;
      end Set_Up;

   end Http_Tests;

   overriding
   procedure Set_Up (T : in out Test) is
   begin
      Log.Info ("Starting test server");
      T.Server := new Test_Server;
      T.Server.Start;
   end Set_Up;

   overriding
   procedure Tear_Down (T : in out Test) is
      procedure Free is
         new Ada.Unchecked_Deallocation (Object => Test_Server'Class,
                                         Name   => Test_Server_Access);
   begin
      if T.Server /= null then
         Log.Info ("Stopping test server");
         T.Server.Stop;
         Free (T.Server);
         T.Server := null;
      end if;
   end Tear_Down;

   --  ------------------------------
   --  Process the line received by the server.
   --  ------------------------------
   overriding
   procedure Process_Line (Into   : in out Test_Server;
                           Line   : in Ada.Strings.Unbounded.Unbounded_String;
                           Stream : in out Util.Streams.Texts.Reader_Stream'Class;
                           Client : in out Util.Streams.Sockets.Socket_Stream'Class) is
      L   : constant String := Ada.Strings.Unbounded.To_String (Line);
      Pos : Natural := Util.Strings.Index (L, ' ');
   begin
      if Pos > 0 and Into.Method = UNKNOWN then
         if L (L'First .. Pos - 1) = "GET" then
            Into.Method := GET;
         elsif L (L'First .. Pos - 1) = "POST" then
            Into.Method := POST;
         elsif L (L'First .. Pos - 1) = "PUT" then
            Into.Method := PUT;
         elsif L (L'First .. Pos - 1) = "DELETE" then
            Into.Method := DELETE;
         else
            Into.Method := UNKNOWN;
         end if;
      end if;

      Pos := Util.Strings.Index (L, ':');
      if Pos > 0 then
         if L (L'First .. Pos) = "Content-Type:" then
            Into.Content_Type
              := Ada.Strings.Unbounded.To_Unbounded_String (L (Pos + 2 .. L'Last - 2));
         elsif L (L'First .. Pos) = "Content-Length:" then
            Into.Length := Natural'Value (L (Pos + 1 .. L'Last - 2));

         end if;
      end if;

      --  Don't answer if we check the timeout.
      if Into.Test_Timeout then
         return;
      end if;
      if L'Length = 2 and then Into.Length > 0 then
         for I in 1 .. Into.Length loop
            declare
               C : Character;
            begin
               Stream.Read (C);
               Ada.Strings.Unbounded.Append (Into.Result, C);
            end;
         end loop;
         declare
            Output : Util.Streams.Texts.Print_Stream;
         begin
            Output.Initialize (Client'Unchecked_Access);
            Output.Write ("HTTP/1.1 200 Found" & ASCII.CR & ASCII.LF);
            Output.Write ("Content-Length: 4" & ASCII.CR & ASCII.LF);
            Output.Write (ASCII.CR & ASCII.LF);
            Output.Write ("OK" & ASCII.CR & ASCII.LF);
            Output.Flush;
         end;
      elsif L'Length = 2 then
         declare
            Output : Util.Streams.Texts.Print_Stream;
         begin
            Output.Initialize (Client'Unchecked_Access);
            Output.Write ("HTTP/1.1 204 No Content" & ASCII.CR & ASCII.LF);
            Output.Write (ASCII.CR & ASCII.LF);
            Output.Flush;
         end;
      end if;
      Log.Info ("Received: {0}", L);
   end Process_Line;

   --  ------------------------------
   --  Get the test server base URI.
   --  ------------------------------
   function Get_Uri (T : in Test) return String is

   begin
      return "http://" & T.Server.Get_Host & ":" & Util.Strings.Image (T.Server.Get_Port);
   end Get_Uri;

   --  ------------------------------
   --  Test the http Get operation.
   --  ------------------------------
   procedure Test_Http_Get (T : in out Test) is
      Request : Client;
      Reply   : Response;
   begin
      Request.Get ("http://www.google.com", Reply);
      Request.Set_Timeout (5.0);
      T.Assert (Reply.Get_Status = 200 or Reply.Get_Status = 302,
                "Get status is invalid: " & Natural'Image (Reply.Get_Status));

      Util.Http.Tools.Save_Response (Util.Tests.Get_Test_Path ("http_get.txt"), Reply, True);

      --  Check the content.
      declare
         Content : constant String := Util.Strings.Transforms.To_Lower_Case (Reply.Get_Body);
      begin
         Util.Tests.Assert_Matches (T, ".*html.*", Content, "Invalid GET content");
      end;

      T.Assert (Reply.Contains_Header ("Content-Type"), "Header Content-Type not found");
      T.Assert (not Reply.Contains_Header ("Content-Type-Invalid-Missing"),
                "Some invalid header found");

      --  Check one header.
      declare
         Content : constant String := Reply.Get_Header ("Content-Type");
      begin
         T.Assert (Content'Length > 0, "Empty Content-Type header");
         Util.Tests.Assert_Matches (T, ".*text/html.*", Content, "Invalid content type");
      end;
   end Test_Http_Get;

   --  ------------------------------
   --  Test the http POST operation.
   --  ------------------------------
   procedure Test_Http_Post (T : in out Test) is
      Request : Client;
      Reply   : Response;
      Uri     : constant String := T.Get_Uri;
   begin
      Log.Info ("Post on " & Uri);

      T.Server.Method := UNKNOWN;
      Request.Post (Uri & "/post",
                    "p1=1", Reply);

      T.Assert (T.Server.Method = POST, "Invalid method received by server");
      Util.Tests.Assert_Equals (T, "application/x-www-form-urlencoded", T.Server.Content_Type,
                                "Invalid content type received by server");
      Util.Tests.Assert_Equals (T, "OK" & ASCII.CR & ASCII.LF, Reply.Get_Body, "Invalid response");
      Util.Http.Tools.Save_Response (Util.Tests.Get_Test_Path ("http_post.txt"), Reply, True);

   end Test_Http_Post;

   --  ------------------------------
   --  Test the http PUT operation.
   --  ------------------------------
   procedure Test_Http_Put (T : in out Test) is
      Request : Client;
      Reply   : Response;
      Uri     : constant String := T.Get_Uri;
   begin
      Log.Info ("Put on " & Uri);

      T.Server.Method := UNKNOWN;
      Request.Add_Header ("Content-Type", "application/x-www-form-urlencoded");
      Request.Set_Timeout (1.0);
      T.Assert (Request.Contains_Header ("Content-Type"), "Missing Content-Type");
      Request.Put (Uri & "/put",
                   "p1=1", Reply);

      T.Assert (T.Server.Method = PUT, "Invalid method received by server");
      Util.Tests.Assert_Equals (T, "application/x-www-form-urlencoded", T.Server.Content_Type,
                                "Invalid content type received by server");
      Util.Tests.Assert_Equals (T, "OK" & ASCII.CR & ASCII.LF, Reply.Get_Body, "Invalid response");
      Util.Http.Tools.Save_Response (Util.Tests.Get_Test_Path ("http_put.txt"), Reply, True);

   end Test_Http_Put;

   --  ------------------------------
   --  Test the http DELETE operation.
   --  ------------------------------
   procedure Test_Http_Delete (T : in out Test) is
      Request : Client;
      Reply   : Response;
      Uri     : constant String := T.Get_Uri;
   begin
      Log.Info ("Delete on " & Uri);

      T.Server.Method := UNKNOWN;
      Request.Add_Header ("Content-Type", "application/x-www-form-urlencoded");
      Request.Set_Timeout (1.0);
      T.Assert (Request.Contains_Header ("Content-Type"), "Missing Content-Type");
      Request.Delete (Uri & "/delete", Reply);

      T.Assert (T.Server.Method = DELETE, "Invalid method received by server");
      Util.Tests.Assert_Equals (T, "application/x-www-form-urlencoded", T.Server.Content_Type,
                                "Invalid content type received by server");
      Util.Tests.Assert_Equals (T, "", Reply.Get_Body, "Invalid response");
      Util.Tests.Assert_Equals (T, 204, Reply.Get_Status, "Invalid status response");

   end Test_Http_Delete;

   --  ------------------------------
   --  Test the http timeout.
   --  ------------------------------
   procedure Test_Http_Timeout (T : in out Test) is
      Request : Client;
      Reply   : Response;
      Uri     : constant String := T.Get_Uri;
   begin
      Log.Info ("Timeout on " & Uri);

      T.Server.Test_Timeout := True;
      T.Server.Method := UNKNOWN;
      Request.Set_Timeout (0.5);
      begin
         Request.Get (Uri & "/timeout", Reply);
         T.Fail ("No Connection_Error exception raised");

      exception
         when Connection_Error =>
            null;
      end;

   end Test_Http_Timeout;

end Util.Http.Clients.Tests;

Add some timeout for the HTTP client operations


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

package Druss.Commands.Bboxes is

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

   procedure Discover (Command   : in Command_Type;
                       Context   : in out Context_Type);

   --  Add the bbox with the given IP address.
   procedure Add_Bbox (Command : in Command_Type;
                       IP      : in String;
                       Context : in out Context_Type);

   --  Enable or disable the bbox management by Druss.
   procedure Do_Enable (Command   : in Command_Type;
                        Args      : in Util.Commands.Argument_List'Class;
                        State     : in Boolean;
                        Context   : in out Context_Type);

   --  Execute the command with the arguments.  The command name is passed with the command
   --  arguments.
   overriding
   procedure Execute (Command   : in Command_Type;
                      Name      : in String;
                      Args      : in Druss.Commands.Argument_List'Class;
                      Context   : in out Context_Type);

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

end Druss.Commands.Bboxes;

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

package Druss.Commands.Bboxes is

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

   procedure Discover (Command   : in Command_Type;
                       Context   : in out Context_Type);

   --  Add the bbox with the given IP address.
   procedure Add_Bbox (Command : in Command_Type;
                       IP      : in String;
                       Context : in out Context_Type);

   --  Enable or disable the bbox management by Druss.
   procedure Do_Enable (Command   : in Command_Type;
                        Args      : in Util.Commands.Argument_List'Class;
                        Context   : in out Context_Type);

   --  Set the password to be used by the Bbox API to connect to the box.
   procedure Do_Password (Command   : in Command_Type;
                          Args      : in Util.Commands.Argument_List'Class;
                          Context   : in out Context_Type);

   --  Execute the command with the arguments.  The command name is passed with the command
   --  arguments.
   overriding
   procedure Execute (Command   : in Command_Type;
                      Name      : in String;
                      Args      : in Druss.Commands.Argument_List'Class;
                      Context   : in out Context_Type);

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

end Druss.Commands.Bboxes;

Declare the Do_Password procedure

Declare the Do_Password procedure


-----------------------------------------------------------------------
--  html -- ASF HTML Components
--  Copyright (C) 2009, 2010 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 EL.Objects;
with ASF.Components.Core;
with Util.Strings;
package body ASF.Components.Html.Text is

   use EL.Objects;

   TEXT_ATTRIBUTE_NAMES  : Util.Strings.String_Set.Set;

   LABEL_ATTRIBUTE_NAMES : Util.Strings.String_Set.Set;

   --  ------------------------------
   --  Get the value to write on the output.
   --  ------------------------------
   function Get_Value (UI    : in UIOutput) return EL.Objects.Object is
   begin
      return UI.Get_Attribute (UI.Get_Context.all, "value");
--        return UI.Value;
   end Get_Value;

   --  ------------------------------
   --  Set the value to write on the output.
   --  ------------------------------
   procedure Set_Value (UI    : in out UIOutput;
                        Value : in EL.Objects.Object) is
   begin
      UI.Value := Value;
   end Set_Value;

   procedure Write_Output (UI      : in UIOutput;
                           Context : in out Faces_Context'Class;
                           Value   : in EL.Objects.Object) is
      Writer : constant ResponseWriter_Access := Context.Get_Response_Writer;
      Escape : constant Object := UI.Get_Attribute (Context, "escape");
   begin
      Writer.Start_Optional_Element ("span");
      UI.Render_Attributes (Context, TEXT_ATTRIBUTE_NAMES, Writer);
      if Is_Null (Escape) or To_Boolean (Escape) then
         Writer.Write_Text (Value);
      else
         Writer.Write_Text (Value);
      end if;
      Writer.End_Optional_Element ("span");
   end Write_Output;

   procedure Encode_Begin (UI      : in UIOutput;
                           Context : in out Faces_Context'Class) is
   begin
      if UI.Is_Rendered (Context) then
         UI.Write_Output (Context => Context,
                          Value   => UI.Get_Value);
      end if;
   end Encode_Begin;

   procedure Encode_Begin (UI      : in UILabel;
                           Context : in out Faces_Context'Class) is
      Writer : ResponseWriter_Access;
   begin
      if UI.Is_Rendered (Context) then
         Writer := Context.Get_Response_Writer;
         Writer.Start_Element ("label");
         UI.Render_Attributes (Context, TEXT_ATTRIBUTE_NAMES, Writer);
      end if;
   end Encode_Begin;

   procedure Encode_End (UI      : in UILabel;
                         Context : in out Faces_Context'Class) is
      Writer : ResponseWriter_Access;
   begin
      if UI.Is_Rendered (Context) then
         Writer := Context.Get_Response_Writer;
         Writer.End_Element ("label");
      end if;
   end Encode_End;

   type Object_Array is array (Positive range <>) of EL.Objects.Object;

   package Formats is
     new Util.Strings.Formats (Stream => Ada.Strings.Unbounded.Unbounded_String,
                               Char   => Character,
                               Input  => String,
                               Value  => EL.Objects.Object,
                               Value_List => Object_Array,
                               Put        => Ada.Strings.Unbounded.Append,
                               To_Input   => EL.Objects.To_String);

   procedure Encode_Begin (UI      : in UIOutputFormat;
                           Context : in out Faces_Context'Class) is
      use ASF.Components.Core;
   begin
      if not UI.Is_Rendered (Context) then
         return;
      end if;

      declare
         Params : constant UIParameter_Access_Array := Get_Parameters (UI);
         Values : Object_Array (Params'Range);
         Result : Ada.Strings.Unbounded.Unbounded_String;
         Fmt    : constant String := EL.Objects.To_String (UI.Get_Value);
      begin
         --  Get the values associated with the parameters.
         for I in Params'Range loop
            Values (I) := Params (I).Get_Value (Context);
         end loop;
         Formats.Format (Fmt, Values, Result);
         UI.Write_Output (Context => Context,
                          Value   => EL.Objects.To_Object (Result));
      end;
   end Encode_Begin;

begin
   Set_Text_Attributes (TEXT_ATTRIBUTE_NAMES);
   Set_Text_Attributes (LABEL_ATTRIBUTE_NAMES);
   Set_Interactive_Attributes (LABEL_ATTRIBUTE_NAMES);
end ASF.Components.Html.Text;

-----------------------------------------------------------------------
--  html -- ASF HTML Components
--  Copyright (C) 2009, 2010 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 EL.Objects;
with ASF.Components.Core;
with Util.Texts.Formats;
package body ASF.Components.Html.Text is

   use EL.Objects;

   TEXT_ATTRIBUTE_NAMES  : Util.Strings.String_Set.Set;

   LABEL_ATTRIBUTE_NAMES : Util.Strings.String_Set.Set;

   --  ------------------------------
   --  Get the value to write on the output.
   --  ------------------------------
   function Get_Value (UI    : in UIOutput) return EL.Objects.Object is
   begin
      return UI.Get_Attribute (UI.Get_Context.all, "value");
--        return UI.Value;
   end Get_Value;

   --  ------------------------------
   --  Set the value to write on the output.
   --  ------------------------------
   procedure Set_Value (UI    : in out UIOutput;
                        Value : in EL.Objects.Object) is
   begin
      UI.Value := Value;
   end Set_Value;

   procedure Write_Output (UI      : in UIOutput;
                           Context : in out Faces_Context'Class;
                           Value   : in EL.Objects.Object) is
      Writer : constant ResponseWriter_Access := Context.Get_Response_Writer;
      Escape : constant Object := UI.Get_Attribute (Context, "escape");
   begin
      Writer.Start_Optional_Element ("span");
      UI.Render_Attributes (Context, TEXT_ATTRIBUTE_NAMES, Writer);
      if Is_Null (Escape) or To_Boolean (Escape) then
         Writer.Write_Text (Value);
      else
         Writer.Write_Text (Value);
      end if;
      Writer.End_Optional_Element ("span");
   end Write_Output;

   procedure Encode_Begin (UI      : in UIOutput;
                           Context : in out Faces_Context'Class) is
   begin
      if UI.Is_Rendered (Context) then
         UI.Write_Output (Context => Context,
                          Value   => UI.Get_Value);
      end if;
   end Encode_Begin;

   procedure Encode_Begin (UI      : in UILabel;
                           Context : in out Faces_Context'Class) is
      Writer : ResponseWriter_Access;
   begin
      if UI.Is_Rendered (Context) then
         Writer := Context.Get_Response_Writer;
         Writer.Start_Element ("label");
         UI.Render_Attributes (Context, TEXT_ATTRIBUTE_NAMES, Writer);
      end if;
   end Encode_Begin;

   procedure Encode_End (UI      : in UILabel;
                         Context : in out Faces_Context'Class) is
      Writer : ResponseWriter_Access;
   begin
      if UI.Is_Rendered (Context) then
         Writer := Context.Get_Response_Writer;
         Writer.End_Element ("label");
      end if;
   end Encode_End;

   type Object_Array is array (Positive range <>) of EL.Objects.Object;

   package Formats is
     new Util.Texts.Formats (Stream => Ada.Strings.Unbounded.Unbounded_String,
                               Char   => Character,
                               Input  => String,
                               Value  => EL.Objects.Object,
                               Value_List => Object_Array,
                               Put        => Ada.Strings.Unbounded.Append,
                               To_Input   => EL.Objects.To_String);

   procedure Encode_Begin (UI      : in UIOutputFormat;
                           Context : in out Faces_Context'Class) is
      use ASF.Components.Core;
   begin
      if not UI.Is_Rendered (Context) then
         return;
      end if;

      declare
         Params : constant UIParameter_Access_Array := Get_Parameters (UI);
         Values : Object_Array (Params'Range);
         Result : Ada.Strings.Unbounded.Unbounded_String;
         Fmt    : constant String := EL.Objects.To_String (UI.Get_Value);
      begin
         --  Get the values associated with the parameters.
         for I in Params'Range loop
            Values (I) := Params (I).Get_Value (Context);
         end loop;
         Formats.Format (Fmt, Values, Result);
         UI.Write_Output (Context => Context,
                          Value   => EL.Objects.To_Object (Result));
      end;
   end Encode_Begin;

begin
   Set_Text_Attributes (TEXT_ATTRIBUTE_NAMES);
   Set_Text_Attributes (LABEL_ATTRIBUTE_NAMES);
   Set_Interactive_Attributes (LABEL_ATTRIBUTE_NAMES);
end ASF.Components.Html.Text;

Update to use the Utils.Texts.Formats generic package


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

   Tests : aliased Util.Tests.Test_Suite;

   function Suite return Util.Tests.Access_Test_Suite is
      Ret : constant Util.Tests.Access_Test_Suite := Tests'Access;
   begin
      Security.OpenID.Tests.Add_Tests (Ret);
      Security.Permissions.Tests.Add_Tests (Ret);
      Security.Policies.Tests.Add_Tests (Ret);
      return Ret;
   end Suite;

end Security.Testsuite;

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

   Tests : aliased Util.Tests.Test_Suite;

   function Suite return Util.Tests.Access_Test_Suite is
      Ret : constant Util.Tests.Access_Test_Suite := Tests'Access;
   begin
      Security.OAuth.JWT.Tests.Add_Tests (Ret);
      Security.OpenID.Tests.Add_Tests (Ret);
      Security.Permissions.Tests.Add_Tests (Ret);
      Security.Policies.Tests.Add_Tests (Ret);
      return Ret;
   end Suite;

end Security.Testsuite;

Add the new unit tests

Add the new unit tests


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

with Ada.Text_IO;
with Ada.Directories;

with Gen.Utils;
with Gen.Utils.GNAT;
with Gen.Model.Projects;

with Util.Strings.Sets;
with Util.Files;
package body Gen.Commands.Info is

   --  ------------------------------
   --  Execute the command with the arguments.
   --  ------------------------------
   procedure Execute (Cmd       : in Command;
                      Generator : in out Gen.Generator.Handler) is
      pragma Unreferenced (Cmd);

      procedure Collect_Directories (List   : in Gen.Utils.String_List.Vector;
                                     Result : out Gen.Utils.String_List.Vector);

      procedure Print_Model_File (Name : in String;
                                  File : in String;
                                  Done : out Boolean);

      procedure Print_GNAT_Projects (Project : in out Gen.Model.Projects.Project_Definition);

      procedure Print_Dynamo_Projects (Project : in out Model.Projects.Root_Project_Definition);

      procedure Print_Modules (Project : in out Gen.Model.Projects.Project_Definition'Class;
                               Indent  : in Ada.Text_IO.Positive_Count);

      procedure Print_Project (Project : in out Gen.Model.Projects.Root_Project_Definition);

      List  : Gen.Utils.String_List.Vector;
      Names : Util.Strings.Sets.Set;

      procedure Collect_Directories (List : in Gen.Utils.String_List.Vector;
                                     Result : out Gen.Utils.String_List.Vector) is

         procedure Add_Model_Dir (Base_Dir : in String;
                                  Dir : in String);

         procedure Add_Model_Dir (Base_Dir : in String;
                                  Dir : in String) is
            Path : constant String := Util.Files.Compose (Base_Dir, Dir);
         begin
            if not Result.Contains (Path)
              and then Ada.Directories.Exists (Path) then
               Result.Append (Path);
            end if;
         end Add_Model_Dir;

         Iter : Gen.Utils.String_List.Cursor := List.First;
      begin
         while Gen.Utils.String_List.Has_Element (Iter) loop
            declare
               Path : constant String := Gen.Utils.String_List.Element (Iter);
               Dir  : constant String := Ada.Directories.Containing_Directory (Path);
            begin
               Add_Model_Dir (Dir, "db");
               Add_Model_Dir (Dir, "db/regtests");
               Add_Model_Dir (Dir, "db/samples");
            end;
            Gen.Utils.String_List.Next (Iter);
         end loop;
      end Collect_Directories;

      procedure Print_Model_File (Name : in String;
                                  File : in String;
                                  Done : out Boolean) is
         pragma Unreferenced (Name);
      begin
         Ada.Text_IO.Put ("    ");
         Ada.Text_IO.Put_Line (File);
         Done := False;
      end Print_Model_File;

      --  ------------------------------
      --  Print the list of GNAT projects used by the main project.
      --  ------------------------------
      procedure Print_GNAT_Projects (Project : in out Gen.Model.Projects.Project_Definition) is
         use Gen.Utils.GNAT;

         Iter : Project_Info_Vectors.Cursor := Project.Project_Files.First;
         Info : Project_Info;
      begin
         if Project_Info_Vectors.Has_Element (Iter) then
            Ada.Text_IO.Put_Line ("GNAT project files:");
            while Project_Info_Vectors.Has_Element (Iter) loop
               Ada.Text_IO.Put ("   ");
               Info := Project_Info_Vectors.Element (Iter);
               Ada.Text_IO.Put_Line (Ada.Strings.Unbounded.To_String (Info.Path));
               Project_Info_Vectors.Next (Iter);
            end loop;
         end if;
      end Print_GNAT_Projects;

      --  ------------------------------
      --  Print the list of Dynamo modules
      --  ------------------------------
      procedure Print_Modules (Project : in out Gen.Model.Projects.Project_Definition'Class;
                               Indent  : in Ada.Text_IO.Positive_Count) is
         use Gen.Model.Projects;
         use type Ada.Text_IO.Positive_Count;

         Iter : Project_Vectors.Cursor := Project.Modules.First;
         Ref  : Model.Projects.Project_Reference;
      begin
         if Project_Vectors.Has_Element (Iter) then
            Ada.Text_IO.Set_Col (Indent);
            Ada.Text_IO.Put_Line ("Dynamo plugins:");
            while Project_Vectors.Has_Element (Iter) loop
               Ref := Project_Vectors.Element (Iter);
               Ada.Text_IO.Set_Col (Indent);
               Ada.Text_IO.Put ("   ");
               Ada.Text_IO.Put (Ada.Strings.Unbounded.To_String (Ref.Name));
               Ada.Text_IO.Set_Col (Indent + 30);
               if Ref.Project /= null then
                  Ada.Text_IO.Put_Line (Ada.Strings.Unbounded.To_String (Ref.Project.Path));
               else
                  Ada.Text_IO.Put_Line ("?");
               end if;
               Project_Vectors.Next (Iter);
            end loop;

            Iter := Project.Modules.First;
            while Project_Vectors.Has_Element (Iter) loop
               Ref := Project_Vectors.Element (Iter);
               if Ref.Project /= null and then not Ref.Project.Modules.Is_Empty then
                  declare
                     Name : constant String := Ada.Strings.Unbounded.To_String (Ref.Name);
                  begin
                     Ada.Text_IO.Set_Col (Indent);
                     if Names.Contains (Name) then
                        Ada.Text_IO.Put_Line ("!! " & Name);
                     else
                        Names.Insert (Name);
                        Ada.Text_IO.Put_Line ("== " & Name);
                        Print_Modules (Ref.Project.all, Indent + 4);
                        Names.Delete (Name);
                     end if;
                  end;
               end if;
               Project_Vectors.Next (Iter);
            end loop;
         end if;
      end Print_Modules;

      --  ------------------------------
      --  Print the list of Dynamo projects used by the main project.
      --  ------------------------------
      procedure Print_Dynamo_Projects (Project : in out Model.Projects.Root_Project_Definition) is
         Iter : Gen.Utils.String_List.Cursor := Project.Dynamo_Files.First;
      begin
         if Gen.Utils.String_List.Has_Element (Iter) then
            Ada.Text_IO.Put_Line ("Dynamo project files:");
            while Gen.Utils.String_List.Has_Element (Iter) loop
               Ada.Text_IO.Put ("   ");
               Ada.Text_IO.Put_Line (Gen.Utils.String_List.Element (Iter));
               Gen.Utils.String_List.Next (Iter);
            end loop;
         end if;
      end Print_Dynamo_Projects;

      procedure Print_Project (Project : in out Gen.Model.Projects.Root_Project_Definition) is
      begin
         Print_GNAT_Projects (Gen.Model.Projects.Project_Definition (Project));
         Print_Dynamo_Projects (Project);

         Print_Modules (Project, 1);
         declare
            Model_Dirs : Gen.Utils.String_List.Vector;
         begin
            Collect_Directories (List, Model_Dirs);
            declare
               Iter : Gen.Utils.String_List.Cursor := Model_Dirs.First;
            begin
               Ada.Text_IO.Put_Line ("ADO model files:");
               while Gen.Utils.String_List.Has_Element (Iter) loop
                  Ada.Text_IO.Put ("   ");
                  Ada.Text_IO.Put_Line (Gen.Utils.String_List.Element (Iter));
                  Util.Files.Iterate_Files_Path (Pattern => "*.xml",
                                                 Path    => Gen.Utils.String_List.Element (Iter),
                                                 Process => Print_Model_File'Access);
                  Gen.Utils.String_List.Next (Iter);
               end loop;
            end;
         end;
      end Print_Project;

   begin
      Generator.Read_Project ("dynamo.xml", True);

      Generator.Update_Project (Print_Project'Access);
   end Execute;

   --  ------------------------------
   --  Write the help associated with the command.
   --  ------------------------------
   procedure Help (Cmd       : in Command;
                   Generator : in out Gen.Generator.Handler) is
      pragma Unreferenced (Cmd, Generator);
   begin
      Ada.Text_IO.Put_Line ("info: Print information about the current project");
      Ada.Text_IO.Put_Line ("Usage: info");
      Ada.Text_IO.New_Line;
   end Help;

end Gen.Commands.Info;

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

with Ada.Text_IO;
with Ada.Directories;

with Gen.Utils;
with Gen.Utils.GNAT;
with Gen.Model.Projects;

with Util.Strings.Sets;
with Util.Files;
package body Gen.Commands.Info is

   --  ------------------------------
   --  Execute the command with the arguments.
   --  ------------------------------
   procedure Execute (Cmd       : in Command;
                      Generator : in out Gen.Generator.Handler) is
      pragma Unreferenced (Cmd);

      procedure Collect_Directories (List   : in Gen.Utils.String_List.Vector;
                                     Result : out Gen.Utils.String_List.Vector);

      procedure Print_Model_File (Name : in String;
                                  File : in String;
                                  Done : out Boolean);

      procedure Print_GNAT_Projects (Project : in out Gen.Model.Projects.Project_Definition);

      procedure Print_Dynamo_Projects (Project : in out Model.Projects.Root_Project_Definition);

      procedure Print_Modules (Project : in out Gen.Model.Projects.Project_Definition'Class;
                               Indent  : in Ada.Text_IO.Positive_Count);

      procedure Print_Project (Project : in out Gen.Model.Projects.Root_Project_Definition);

      List  : Gen.Utils.String_List.Vector;
      Names : Util.Strings.Sets.Set;

      procedure Collect_Directories (List : in Gen.Utils.String_List.Vector;
                                     Result : out Gen.Utils.String_List.Vector) is

         procedure Add_Model_Dir (Base_Dir : in String;
                                  Dir : in String);

         procedure Add_Model_Dir (Base_Dir : in String;
                                  Dir : in String) is
            Path : constant String := Util.Files.Compose (Base_Dir, Dir);
         begin
            if not Result.Contains (Path)
              and then Ada.Directories.Exists (Path) then
               Result.Append (Path);
            end if;
         end Add_Model_Dir;

         Iter : Gen.Utils.String_List.Cursor := List.First;
      begin
         while Gen.Utils.String_List.Has_Element (Iter) loop
            declare
               Path : constant String := Gen.Utils.String_List.Element (Iter);
               Dir  : constant String := Ada.Directories.Containing_Directory (Path);
            begin
               Add_Model_Dir (Dir, "db");
               Add_Model_Dir (Dir, "db/regtests");
               Add_Model_Dir (Dir, "db/samples");
            end;
            Gen.Utils.String_List.Next (Iter);
         end loop;
      end Collect_Directories;

      procedure Print_Model_File (Name : in String;
                                  File : in String;
                                  Done : out Boolean) is
         pragma Unreferenced (Name);
      begin
         Ada.Text_IO.Put ("    ");
         Ada.Text_IO.Put_Line (File);
         Done := False;
      end Print_Model_File;

      --  ------------------------------
      --  Print the list of GNAT projects used by the main project.
      --  ------------------------------
      procedure Print_GNAT_Projects (Project : in out Gen.Model.Projects.Project_Definition) is
         use Gen.Utils.GNAT;

         Iter : Project_Info_Vectors.Cursor := Project.Project_Files.First;
         Info : Project_Info;
      begin
         if Project_Info_Vectors.Has_Element (Iter) then
            Ada.Text_IO.Put_Line ("GNAT project files:");
            while Project_Info_Vectors.Has_Element (Iter) loop
               Ada.Text_IO.Put ("   ");
               Info := Project_Info_Vectors.Element (Iter);
               Ada.Text_IO.Put_Line (Ada.Strings.Unbounded.To_String (Info.Path));
               Project_Info_Vectors.Next (Iter);
            end loop;
         end if;
      end Print_GNAT_Projects;

      --  ------------------------------
      --  Print the list of Dynamo modules
      --  ------------------------------
      procedure Print_Project_List (Project : in out Gen.Model.Projects.Project_Definition'Class;
                                    Indent  : in Ada.Text_IO.Positive_Count;
                                    List    : in Gen.Model.Projects.Project_Vectors.Vector) is
         use Gen.Model.Projects;
         use type Ada.Text_IO.Positive_Count;

         Iter : Project_Vectors.Cursor := List.First;
         Ref  : Model.Projects.Project_Reference;
      begin
         while Project_Vectors.Has_Element (Iter) loop
            Ref := Project_Vectors.Element (Iter);
            Ada.Text_IO.Set_Col (Indent);
            Ada.Text_IO.Put ("   ");
            Ada.Text_IO.Put (Ada.Strings.Unbounded.To_String (Ref.Name));
            Ada.Text_IO.Set_Col (Indent + 30);
            if Ref.Project /= null then
               Ada.Text_IO.Put_Line (Ada.Strings.Unbounded.To_String (Ref.Project.Path));
            else
               Ada.Text_IO.Put_Line ("?");
            end if;
            Project_Vectors.Next (Iter);
         end loop;
      end Print_Project_List;

      --  ------------------------------
      --  Print the list of Dynamo modules
      --  ------------------------------
      procedure Print_Modules (Project : in out Gen.Model.Projects.Project_Definition'Class;
                               Indent  : in Ada.Text_IO.Positive_Count) is
         use Gen.Model.Projects;
         use type Ada.Text_IO.Positive_Count;

         Iter : Project_Vectors.Cursor := Project.Modules.First;
         Ref  : Model.Projects.Project_Reference;
      begin
         if not Project.Modules.Is_Empty then
            Ada.Text_IO.Set_Col (Indent);
            Ada.Text_IO.Put_Line ("Dynamo plugins:");
            Print_Project_List (Project, Indent, Project.Modules);

            Print_Project_List (Project, Indent, Project.Dependencies);
            Iter := Project.Modules.First;
            while Project_Vectors.Has_Element (Iter) loop
               Ref := Project_Vectors.Element (Iter);
               if Ref.Project /= null and then not Ref.Project.Modules.Is_Empty then
                  declare
                     Name : constant String := Ada.Strings.Unbounded.To_String (Ref.Name);
                  begin
                     Ada.Text_IO.Set_Col (Indent);
                     if Names.Contains (Name) then
                        Ada.Text_IO.Put_Line ("!! " & Name);
                     else
                        Names.Insert (Name);
                        Ada.Text_IO.Put_Line ("== " & Name);
                        Print_Modules (Ref.Project.all, Indent + 4);
                        Names.Delete (Name);
                     end if;
                  end;
               end if;
               Project_Vectors.Next (Iter);
            end loop;
         end if;
      end Print_Modules;

      --  ------------------------------
      --  Print the list of Dynamo projects used by the main project.
      --  ------------------------------
      procedure Print_Dynamo_Projects (Project : in out Model.Projects.Root_Project_Definition) is
         Iter : Gen.Utils.String_List.Cursor := Project.Dynamo_Files.First;
      begin
         if Gen.Utils.String_List.Has_Element (Iter) then
            Ada.Text_IO.Put_Line ("Dynamo project files:");
            while Gen.Utils.String_List.Has_Element (Iter) loop
               Ada.Text_IO.Put ("   ");
               Ada.Text_IO.Put_Line (Gen.Utils.String_List.Element (Iter));
               Gen.Utils.String_List.Next (Iter);
            end loop;
         end if;
      end Print_Dynamo_Projects;

      procedure Print_Project (Project : in out Gen.Model.Projects.Root_Project_Definition) is
      begin
         Print_GNAT_Projects (Gen.Model.Projects.Project_Definition (Project));
         Print_Dynamo_Projects (Project);

         Print_Modules (Project, 1);
         declare
            Model_Dirs : Gen.Utils.String_List.Vector;
         begin
            Collect_Directories (List, Model_Dirs);
            declare
               Iter : Gen.Utils.String_List.Cursor := Model_Dirs.First;
            begin
               Ada.Text_IO.Put_Line ("ADO model files:");
               while Gen.Utils.String_List.Has_Element (Iter) loop
                  Ada.Text_IO.Put ("   ");
                  Ada.Text_IO.Put_Line (Gen.Utils.String_List.Element (Iter));
                  Util.Files.Iterate_Files_Path (Pattern => "*.xml",
                                                 Path    => Gen.Utils.String_List.Element (Iter),
                                                 Process => Print_Model_File'Access);
                  Gen.Utils.String_List.Next (Iter);
               end loop;
            end;
         end;
      end Print_Project;

   begin
      Generator.Read_Project ("dynamo.xml", True);

      Generator.Update_Project (Print_Project'Access);
   end Execute;

   --  ------------------------------
   --  Write the help associated with the command.
   --  ------------------------------
   procedure Help (Cmd       : in Command;
                   Generator : in out Gen.Generator.Handler) is
      pragma Unreferenced (Cmd, Generator);
   begin
      Ada.Text_IO.Put_Line ("info: Print information about the current project");
      Ada.Text_IO.Put_Line ("Usage: info");
      Ada.Text_IO.New_Line;
   end Help;

end Gen.Commands.Info;

Print the dependencies of a dynamo plugin