-----------------------------------------------------------------------
--  wiki-parsers -- Wiki parser
--  Copyright (C) 2011, 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 Wiki.Attributes;
with Wiki.Plugins;
with Wiki.Filters;
with Wiki.Strings;
with Wiki.Documents;
with Wiki.Streams;

--  === Wiki Parsers ===
--  The Wikis.Parsers package implements a parser for several well known wiki formats
--  but also for HTML.  While reading the input, the parser populates a wiki <tt>Document</tt>
--  instance with headers, paragraphs, links, and other elements.
--
--     Engine : Wiki.Parsers.Parser;
--
--  Before using the parser, it must be configured to choose the syntax by using the
--  <tt>Set_Syntax</tt> procedure:
--
--    Engine.Set_Syntax (Wiki.SYNTAX_HTML);
--
--  The parser can be configured to use filters.  A filter is added by using the
--  <tt>Add_Filter</tt> procedure.  A filter is added at begining of the chain so that
--  the filter added last is called first.  The wiki <tt>Document</tt> is always built through
--  the filter chain so this allows filters to change or alter the content that was parsed.
--
--    Engine.Add_Filter (TOC'Unchecked_Access);
--    Engine.Add_Filter (Filter'Unchecked_Access);
--
--  The <tt>Parse</tt> procedure is then used to parse either a string content or some stream
--  represented by the <tt>Input_Stream</tt> interface.  After the <tt>Parse</tt> procedure
--  completes, the <tt>Document</tt> instance holds the wiki document.
--
--    Engine.Parse (Some_Text, Doc);
--
package Wiki.Parsers is

   pragma Preelaborate;

   type Parser is tagged limited private;

   --  Set the plugin factory to find and use plugins.
   procedure Set_Plugin_Factory (Engine  : in out Parser;
                                 Factory : in Wiki.Plugins.Plugin_Factory_Access);

   --  Set the wiki syntax that the wiki engine must use.
   procedure Set_Syntax (Engine : in out Parser;
                         Syntax : in Wiki_Syntax := SYNTAX_MIX);

   --  Add a filter in the wiki engine.
   procedure Add_Filter (Engine : in out Parser;
                         Filter : in Wiki.Filters.Filter_Type_Access);

   --  Set the plugin context.
   procedure Set_Context (Engine  : in out Parser;
                          Context : in Wiki.Plugins.Plugin_Context);

   --  Parse the wiki text contained in Text according to the wiki syntax
   --  defined on the parser.  The string is assumed to be in UTF-8 format.
   procedure Parse (Engine : in out Parser;
                    Text   : in String;
                    Doc    : in out Wiki.Documents.Document);

   --  Parse the wiki text contained in Text according to the wiki syntax
   --  defined on the parser.
   procedure Parse (Engine : in out Parser;
                    Text   : in Wiki.Strings.WString;
                    Doc    : in out Wiki.Documents.Document);

   --  Parse the wiki text contained in Text according to the wiki syntax
   --  defined on the parser.
   procedure Parse (Engine : in out Parser;
                    Text   : in Wiki.Strings.UString;
                    Doc    : in out Wiki.Documents.Document);

   --  Parse the wiki stream managed by <tt>Stream</tt> according to the wiki syntax configured
   --  on the wiki engine.
   procedure Parse (Engine : in out Parser;
                    Stream : in Wiki.Streams.Input_Stream_Access;
                    Doc    : in out Wiki.Documents.Document);

private

   type Parser_Handler is access procedure (P     : in out Parser;
                                            Token : in Wiki.Strings.WChar);

   type Parser_Table is array (0 .. 127) of Parser_Handler;
   type Parser_Table_Access is access constant Parser_Table;

   type Parser is tagged limited record
      Context             : aliased Wiki.Plugins.Plugin_Context;
      Pending             : Wiki.Strings.WChar;
      Has_Pending         : Boolean;
      Previous_Syntax     : Wiki_Syntax;
      Table               : Parser_Table_Access;
      Document            : Wiki.Documents.Document;
      Format              : Wiki.Format_Map;
      Text                : Wiki.Strings.BString (512);
      Empty_Line          : Boolean := True;
      Is_Eof              : Boolean := False;
      In_Paragraph        : Boolean := False;
      In_List             : Boolean := False;
      Need_Paragraph      : Boolean := True;
      Link_Double_Bracket : Boolean := False;
      Link_No_Space       : Boolean := False;
      Is_Dotclear         : Boolean := False;
      Link_Title_First    : Boolean := False;
      Check_Image_Link    : Boolean := False;
      Header_Offset       : Integer := 0;
      Preformat_Column    : Natural := 1;
      Quote_Level         : Natural := 0;
      Escape_Char         : Wiki.Strings.WChar;
      Param_Char          : Wiki.Strings.WChar;
      List_Level          : Natural := 0;
      Reader              : Wiki.Streams.Input_Stream_Access := null;
      Attributes          : Wiki.Attributes.Attribute_List;
   end record;

   --  Peek the next character from the wiki text buffer.
   procedure Peek (P     : in out Parser'Class;
                   Token : out Wiki.Strings.WChar);
   pragma Inline (Peek);

   --  Put back the character so that it will be returned by the next call to Peek.
   procedure Put_Back (P     : in out Parser;
                       Token : in Wiki.Strings.WChar);

   --  Skip all the spaces and tabs as well as end of the current line (CR+LF).
   procedure Skip_End_Of_Line (P : in out Parser);

   --  Skip white spaces and tabs.
   procedure Skip_Spaces (P : in out Parser);

   --  Flush the wiki text that was collected in the text buffer.
   procedure Flush_Text (P : in out Parser);

   --  Flush the wiki dl/dt/dd definition list.
   procedure Flush_List (P : in out Parser);

   --  Append a character to the wiki text buffer.
   procedure Parse_Text (P     : in out Parser;
                         Token : in Wiki.Strings.WChar);

   --  Check if the link refers to an image and must be rendered as an image.
   --  Returns a positive index of the start the the image link.
   function Is_Image (P    : in Parser;
                      Link : in Wiki.Strings.WString) return Natural;

   --  Find the plugin with the given name.
   --  Returns null if there is no such plugin.
   function Find (P    : in Parser;
                  Name : in Wiki.Strings.WString) return Wiki.Plugins.Wiki_Plugin_Access;

   type String_Array is array (Positive range <>) of Wiki.String_Access;

   --  Extract a list of parameters separated by the given separator (ex: '|').
   procedure Parse_Parameters (P          : in out Parser;
                               Separator  : in Wiki.Strings.WChar;
                               Terminator : in Wiki.Strings.WChar;
                               Names      : in String_Array;
                               Max        : in Positive := 200);

   procedure Start_Element (P          : in out Parser;
                            Tag        : in Wiki.Html_Tag;
                            Attributes : in out Wiki.Attributes.Attribute_List);

   procedure End_Element (P    : in out Parser;
                          Tag  : in Wiki.Html_Tag);

   procedure Parse_Token (P     : in out Parser);

end Wiki.Parsers;

-----------------------------------------------------------------------
--  wiki-parsers -- Wiki parser
--  Copyright (C) 2011, 2015, 2016, 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 Wiki.Attributes;
with Wiki.Plugins;
with Wiki.Filters;
with Wiki.Strings;
with Wiki.Documents;
with Wiki.Streams;

--  === Wiki Parsers ===
--  The Wikis.Parsers package implements a parser for several well known wiki formats
--  but also for HTML.  While reading the input, the parser populates a wiki <tt>Document</tt>
--  instance with headers, paragraphs, links, and other elements.
--
--     Engine : Wiki.Parsers.Parser;
--
--  Before using the parser, it must be configured to choose the syntax by using the
--  <tt>Set_Syntax</tt> procedure:
--
--    Engine.Set_Syntax (Wiki.SYNTAX_HTML);
--
--  The parser can be configured to use filters.  A filter is added by using the
--  <tt>Add_Filter</tt> procedure.  A filter is added at begining of the chain so that
--  the filter added last is called first.  The wiki <tt>Document</tt> is always built through
--  the filter chain so this allows filters to change or alter the content that was parsed.
--
--    Engine.Add_Filter (TOC'Unchecked_Access);
--    Engine.Add_Filter (Filter'Unchecked_Access);
--
--  The <tt>Parse</tt> procedure is then used to parse either a string content or some stream
--  represented by the <tt>Input_Stream</tt> interface.  After the <tt>Parse</tt> procedure
--  completes, the <tt>Document</tt> instance holds the wiki document.
--
--    Engine.Parse (Some_Text, Doc);
--
package Wiki.Parsers is

   pragma Preelaborate;

   type Parser is tagged limited private;

   --  Set the plugin factory to find and use plugins.
   procedure Set_Plugin_Factory (Engine  : in out Parser;
                                 Factory : in Wiki.Plugins.Plugin_Factory_Access);

   --  Set the wiki syntax that the wiki engine must use.
   procedure Set_Syntax (Engine : in out Parser;
                         Syntax : in Wiki_Syntax := SYNTAX_MIX);

   --  Add a filter in the wiki engine.
   procedure Add_Filter (Engine : in out Parser;
                         Filter : in Wiki.Filters.Filter_Type_Access);

   --  Set the plugin context.
   procedure Set_Context (Engine  : in out Parser;
                          Context : in Wiki.Plugins.Plugin_Context);

   --  Parse the wiki text contained in Text according to the wiki syntax
   --  defined on the parser.  The string is assumed to be in UTF-8 format.
   procedure Parse (Engine : in out Parser;
                    Text   : in String;
                    Doc    : in out Wiki.Documents.Document);

   --  Parse the wiki text contained in Text according to the wiki syntax
   --  defined on the parser.
   procedure Parse (Engine : in out Parser;
                    Text   : in Wiki.Strings.WString;
                    Doc    : in out Wiki.Documents.Document);

   --  Parse the wiki text contained in Text according to the wiki syntax
   --  defined on the parser.
   procedure Parse (Engine : in out Parser;
                    Text   : in Wiki.Strings.UString;
                    Doc    : in out Wiki.Documents.Document);

   --  Parse the wiki stream managed by <tt>Stream</tt> according to the wiki syntax configured
   --  on the wiki engine.
   procedure Parse (Engine : in out Parser;
                    Stream : in Wiki.Streams.Input_Stream_Access;
                    Doc    : in out Wiki.Documents.Document);

private

   type Parser_Handler is access procedure (P     : in out Parser;
                                            Token : in Wiki.Strings.WChar);

   type Parser_Table is array (0 .. 127) of Parser_Handler;
   type Parser_Table_Access is access constant Parser_Table;

   type Parser is tagged limited record
      Context             : aliased Wiki.Plugins.Plugin_Context;
      Pending             : Wiki.Strings.WChar;
      Has_Pending         : Boolean;
      Previous_Syntax     : Wiki_Syntax;
      Table               : Parser_Table_Access;
      Document            : Wiki.Documents.Document;
      Format              : Wiki.Format_Map;
      Text                : Wiki.Strings.BString (512);
      Empty_Line          : Boolean := True;
      Is_Eof              : Boolean := False;
      In_Paragraph        : Boolean := False;
      In_List             : Boolean := False;
      Need_Paragraph      : Boolean := True;
      Link_Double_Bracket : Boolean := False;
      Link_No_Space       : Boolean := False;
      Is_Dotclear         : Boolean := False;
      Link_Title_First    : Boolean := False;
      Check_Image_Link    : Boolean := False;
      Header_Offset       : Integer := 0;
      Preformat_Column    : Natural := 1;
      Quote_Level         : Natural := 0;
      Escape_Char         : Wiki.Strings.WChar;
      Param_Char          : Wiki.Strings.WChar;
      List_Level          : Natural := 0;
      Reader              : Wiki.Streams.Input_Stream_Access := null;
      Attributes          : Wiki.Attributes.Attribute_List;
   end record;

   --  Peek the next character from the wiki text buffer.
   procedure Peek (P     : in out Parser'Class;
                   Token : out Wiki.Strings.WChar);
   pragma Inline (Peek);

   --  Put back the character so that it will be returned by the next call to Peek.
   procedure Put_Back (P     : in out Parser;
                       Token : in Wiki.Strings.WChar);

   --  Skip all the spaces and tabs as well as end of the current line (CR+LF).
   procedure Skip_End_Of_Line (P : in out Parser);

   --  Skip white spaces and tabs.
   procedure Skip_Spaces (P : in out Parser);

   --  Flush the wiki text that was collected in the text buffer.
   procedure Flush_Text (P : in out Parser);

   --  Flush the wiki dl/dt/dd definition list.
   procedure Flush_List (P : in out Parser);

   --  Append a character to the wiki text buffer.
   procedure Parse_Text (P     : in out Parser;
                         Token : in Wiki.Strings.WChar);

   --  Check if the link refers to an image and must be rendered as an image.
   --  Returns a positive index of the start the the image link.
   function Is_Image (P    : in Parser;
                      Link : in Wiki.Strings.WString) return Natural;

   --  Returns true if we are included from another wiki content.
   function Is_Included (P : in Parser) return Boolean;

   --  Find the plugin with the given name.
   --  Returns null if there is no such plugin.
   function Find (P    : in Parser;
                  Name : in Wiki.Strings.WString) return Wiki.Plugins.Wiki_Plugin_Access;

   type String_Array is array (Positive range <>) of Wiki.String_Access;

   --  Extract a list of parameters separated by the given separator (ex: '|').
   procedure Parse_Parameters (P          : in out Parser;
                               Separator  : in Wiki.Strings.WChar;
                               Terminator : in Wiki.Strings.WChar;
                               Names      : in String_Array;
                               Max        : in Positive := 200);

   procedure Start_Element (P          : in out Parser;
                            Tag        : in Wiki.Html_Tag;
                            Attributes : in out Wiki.Attributes.Attribute_List);

   procedure End_Element (P    : in out Parser;
                          Tag  : in Wiki.Html_Tag);

   procedure Parse_Token (P     : in out Parser);

end Wiki.Parsers;

Declare the Is_Included function

Declare the Is_Included function


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

with Util.Files;
with Util.Test_Caller;
with Util.Measures;

with Security.Contexts;
package body Security.Permissions.Tests is

   use Util.Tests;

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Security.Permissions.Add_Permission",
                       Test_Add_Permission'Access);
      Caller.Add_Test (Suite, "Test Security.Permissions.Get_Permission_Index",
                       Test_Add_Permission'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test Add_Permission and Get_Permission_Index
   --  ------------------------------
   procedure Test_Add_Permission (T : in out Test) is
      Index1, Index2 : Permission_Index;
   begin
      Add_Permission ("test-create-permission", Index1);

      T.Assert (Index1 = Get_Permission_Index ("test-create-permission"),
                "Get_Permission_Index failed");

      Add_Permission ("test-create-permission", Index2);

      T.Assert (Index2 = Index1,
                "Add_Permission failed");

   end Test_Add_Permission;

end Security.Permissions.Tests;

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

with Util.Files;
with Util.Test_Caller;
with Util.Measures;

with Security.Contexts;
package body Security.Permissions.Tests is

   use Util.Tests;

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Security.Permissions.Add_Permission",
                       Test_Add_Permission'Access);
      Caller.Add_Test (Suite, "Test Security.Permissions.Get_Permission_Index",
                       Test_Add_Permission'Access);
      Caller.Add_Test (Suite, "Test Security.Permissions.Definition",
                       Test_Define_Permission'Access);
      Caller.Add_Test (Suite, "Test Security.Permissions.Get_Permission_Index (invalid name)",
                       Test_Get_Invalid_Permission'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test Add_Permission and Get_Permission_Index
   --  ------------------------------
   procedure Test_Add_Permission (T : in out Test) is
      Index1, Index2 : Permission_Index;
   begin
      Add_Permission ("test-create-permission", Index1);

      T.Assert (Index1 = Get_Permission_Index ("test-create-permission"),
                "Get_Permission_Index failed");

      Add_Permission ("test-create-permission", Index2);

      T.Assert (Index2 = Index1,
                "Add_Permission failed");

   end Test_Add_Permission;

   --  ------------------------------
   --  Test the permission created by the Definition package.
   --  ------------------------------
   procedure Test_Define_Permission (T : in out Test) is
      Index : Permission_Index;
   begin
      Index := Get_Permission_Index ("admin");
      T.Assert (P_Admin.Permission = Index, "Invalid permission for admin");

      Index := Get_Permission_Index ("create");
      T.Assert (P_Create.Permission = Index, "Invalid permission for create");

      Index := Get_Permission_Index ("update");
      T.Assert (P_Update.Permission = Index, "Invalid permission for update");

      Index := Get_Permission_Index ("delete");
      T.Assert (P_Delete.Permission = Index, "Invalid permission for delete");

      T.Assert (P_Admin.Permission /= P_Create.Permission, "Admin or create permission invalid");
      T.Assert (P_Admin.Permission /= P_Update.Permission, "Admin or update permission invalid");
      T.Assert (P_Admin.Permission /= P_Delete.Permission, "Admin or delete permission invalid");
      T.Assert (P_Create.Permission /= P_Update.Permission, "Create or update permission invalid");
      T.Assert (P_Create.Permission /= P_Delete.Permission, "Create or delete permission invalid");
      T.Assert (P_Update.Permission /= P_Delete.Permission, "Create or delete permission invalid");
   end Test_Define_Permission;

   --  ------------------------------
   --  Test Get_Permission on invalid permission name.
   --  ------------------------------
   procedure Test_Get_Invalid_Permission (T : in out Test) is
      Index : Permission_Index;
   begin
      Index := Get_Permission_Index ("invalid");
      T.Assert (Index = Index - 1,
                "No exception raised by Get_Permission_Index for an invalid name");

   exception
      when Invalid_Name =>
         null;
   end Test_Get_Invalid_Permission;

end Security.Permissions.Tests;

Implement the new unit tests for Permissions.Definition package


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

with Ada.Text_IO;
with Ada.Strings.Fixed;
with Ada.Characters.Latin_1;

with Ahven.Parameters;
with Ahven.AStrings;
with Ahven.Long_AStrings;

package body Ahven.Tap_Runner is
   use Ada.Text_IO;
   use Ahven.Framework;
   use Ahven.AStrings;

   function Count_Image (Count : Test_Count_Type) return String is
      use Ada.Strings;
   begin
      return Fixed.Trim (Test_Count_Type'Image (Count), Both);
   end Count_Image;

   procedure Print_Data (Message : String; Prefix : String) is
      Start_Of_Line : Boolean := True;
   begin
      for I in Message'Range loop
         if Start_Of_Line then
            Put (Prefix);
            Start_Of_Line := False;
         end if;
         if Message (I) = Ada.Characters.Latin_1.LF then
            New_Line;
            Start_Of_Line := True;
         elsif Message (I) /= Ada.Characters.Latin_1.CR then
            Put (Message (I));
         end if;
      end loop;
      if not Start_Of_Line then
         New_Line;
      end if;
   end Print_Data;

   procedure Run (Suite : in out Framework.Test'Class) is
      Listener : Tap_Listener;
      Params   : Parameters.Parameter_Info;
   begin
      Parameters.Parse_Parameters (Parameters.TAP_PARAMETERS, Params);

      Listener.Verbose := Parameters.Verbose (Params);
      Listener.Capture_Output := Parameters.Capture (Params);

      if Parameters.Single_Test (Params) then
         Put_Line ("1.." & Count_Image (Test_Count
           (Suite, Parameters.Test_Name (Params))));
         Framework.Execute
           (T         => Suite,
            Test_Name => Parameters.Test_Name (Params),
            Listener  => Listener,
            Timeout   => Parameters.Timeout (Params));
      else
         Put_Line ("1.." & Count_Image (Test_Count (Suite)));
         Framework.Execute (Suite, Listener, Parameters.Timeout (Params));
      end if;
   exception
      when Parameters.Invalid_Parameter =>
         Parameters.Usage (Parameters.TAP_PARAMETERS);
   end Run;

   procedure Print_Info (Info : Context) is
   begin
      if Length (Info.Message) > 0 then
         Print_Data (Message => To_String (Info.Message), Prefix => "# ");
      end if;
      if Long_AStrings.Length (Info.Long_Message) > 0 then
         Print_Data
           (Message => Long_AStrings.To_String (Info.Long_Message),
            Prefix  => "# ");
      end if;
   end Print_Info;

   procedure Print_Log_File (Filename : String; Prefix : String) is
      Handle : File_Type;
      Char   : Character := ' ';
      First  : Boolean := True;
      Start_Of_Line : Boolean := True;
   begin
      Open (Handle, In_File, Filename);
      loop
         exit when End_Of_File (Handle);
         Get (Handle, Char);
         if First then
            Put_Line (Prefix & "===== Output =======");
            First := False;
         end if;
         if Start_Of_Line then
            Put (Prefix);
            Start_Of_Line := False;
         end if;
         Put (Char);
         if End_Of_Line (Handle) then
            New_Line;
            Start_Of_Line := True;
         end if;
      end loop;
      Close (Handle);
      if not First then
         Put_Line (Prefix & "====================");
      end if;
   exception
      when Name_Error =>
         -- Missing output file is ok.
         Put_Line (Prefix & "no output");
   end Print_Log_File;

   procedure Add_Pass (Listener : in out Tap_Listener;
                       Info     :        Context) is
      use Ada.Strings;
      use Ada.Strings.Fixed;
   begin
      if Listener.Capture_Output then
         Temporary_Output.Restore_Output;
         Temporary_Output.Close_Temp (Listener.Output_File);
      end if;

      Put ("ok ");
      Put (Count_Image (Listener.Current_Test) & " ");
      Put (To_String (Info.Test_Name) & ": " & To_String (Info.Routine_Name));
      New_Line;
   end Add_Pass;

   procedure Report_Not_Ok (Listener : in out Tap_Listener;
                            Info     :        Context;
                            Severity :        String) is
      pragma Unreferenced (Severity);

      use Ada.Strings;
      use Ada.Strings.Fixed;
   begin
      if Listener.Capture_Output then
         Temporary_Output.Restore_Output;
         Temporary_Output.Close_Temp (Listener.Output_File);
      end if;

      Put ("not ok ");
      Put (Count_Image (Listener.Current_Test) & " ");
      Put (To_String (Info.Test_Name) & ": " & To_String (Info.Routine_Name));
      New_Line;

      if Listener.Verbose then
         Print_Info (Info);
         if Listener.Capture_Output then
            Print_Log_File
              (Filename => Temporary_Output.Get_Name (Listener.Output_File),
               Prefix   => "# ");
         end if;
      end if;
   end Report_Not_Ok;

   procedure Add_Failure (Listener : in out Tap_Listener;
                          Info     :        Context) is
   begin
      Report_Not_Ok (Listener, Info, "fail");
   end Add_Failure;

   procedure Add_Error (Listener : in out Tap_Listener;
                        Info     :        Context) is
   begin
      Report_Not_Ok (Listener, Info, "error");
   end Add_Error;

   procedure Add_Skipped (Listener : in out Tap_Listener;
                          Info     :        Context) is
      use Ada.Strings;
      use Ada.Strings.Fixed;
   begin
      if Listener.Capture_Output then
         Temporary_Output.Restore_Output;
         Temporary_Output.Close_Temp (Listener.Output_File);
      end if;

      Put ("ok ");
      Put (Count_Image (Listener.Current_Test) & " ");
      Put (To_String (Info.Test_Name) & ": " & To_String (Info.Routine_Name));
      Put (" # SKIP " & To_String (Info.Message));
      New_Line;
   end Add_Skipped;

   procedure Start_Test (Listener : in out Tap_Listener;
                         Info     :        Context) is
   begin
      if Info.Test_Kind = ROUTINE then
         Listener.Current_Test := Listener.Current_Test + 1;
         if Listener.Capture_Output then
            Temporary_Output.Create_Temp (Listener.Output_File);
            Temporary_Output.Redirect_Output (Listener.Output_File);
         end if;
      end if;
   end Start_Test;

   procedure End_Test (Listener : in out Tap_Listener;
                       Info     :        Context) is
      pragma Unreferenced (Info);

      Handle : Ada.Text_IO.File_Type;
   begin
      if Listener.Capture_Output then
         Ada.Text_IO.Open (Handle, Ada.Text_IO.Out_File,
                           Temporary_Output.Get_Name (Listener.Output_File));
         Ada.Text_IO.Delete (Handle);
      end if;
   exception
      when Name_Error =>
         -- Missing file is safe to ignore, we are going to delete it anyway
         null;
   end End_Test;
end Ahven.Tap_Runner;

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

with Ada.Text_IO;
with Ada.Strings.Fixed;
with Ada.Characters.Latin_1;

with Ahven.Parameters;
with Ahven.AStrings;
with Ahven.Long_AStrings;

package body Ahven.Tap_Runner is
   use Ada.Text_IO;
   use Ahven.Framework;
   use Ahven.AStrings;

   function Count_Image (Count : Test_Count_Type) return String is
      use Ada.Strings;
   begin
      return Fixed.Trim (Test_Count_Type'Image (Count), Both);
   end Count_Image;

   procedure Print_Data (Message : String; Prefix : String) is
      Start_Of_Line : Boolean := True;
   begin
      for I in Message'Range loop
         if Start_Of_Line then
            Put (Prefix);
            Start_Of_Line := False;
         end if;
         if Message (I) = Ada.Characters.Latin_1.LF then
            New_Line;
            Start_Of_Line := True;
         elsif Message (I) /= Ada.Characters.Latin_1.CR then
            Put (Message (I));
         end if;
      end loop;
      if not Start_Of_Line then
         New_Line;
      end if;
   end Print_Data;

   procedure Run (Suite : in out Framework.Test'Class) is
      Listener : Tap_Listener;
      Params   : Parameters.Parameter_Info;
   begin
      Parameters.Parse_Parameters (Parameters.TAP_PARAMETERS, Params);

      Listener.Verbose := Parameters.Verbose (Params);
      Listener.Capture_Output := Parameters.Capture (Params);

      if Parameters.Single_Test (Params) then
         Put_Line ("1.." & Count_Image (Test_Count
           (Suite, Parameters.Test_Name (Params))));
         Framework.Execute
           (T         => Suite,
            Test_Name => Parameters.Test_Name (Params),
            Listener  => Listener,
            Timeout   => Parameters.Timeout (Params));
      else
         Put_Line ("1.." & Count_Image (Test_Count (Suite)));
         Framework.Execute (Suite, Listener, Parameters.Timeout (Params));
      end if;
   exception
      when Parameters.Invalid_Parameter =>
         Parameters.Usage (Parameters.TAP_PARAMETERS);
   end Run;

   procedure Print_Info (Info : Context) is
   begin
      if Length (Info.Message) > 0 then
         Print_Data (Message => To_String (Info.Message), Prefix => "# ");
      end if;
      if Long_AStrings.Length (Info.Long_Message) > 0 then
         Print_Data
           (Message => Long_AStrings.To_String (Info.Long_Message),
            Prefix  => "# ");
      end if;
   end Print_Info;

   procedure Print_Log_File (Filename : String; Prefix : String) is
      Handle : File_Type;
      Char   : Character := ' ';
      First  : Boolean := True;
      Start_Of_Line : Boolean := True;
   begin
      Open (Handle, In_File, Filename);
      loop
         exit when End_Of_File (Handle);
         Get (Handle, Char);
         if First then
            Put_Line (Prefix & "===== Output =======");
            First := False;
         end if;
         if Start_Of_Line then
            Put (Prefix);
            Start_Of_Line := False;
         end if;
         Put (Char);
         if End_Of_Line (Handle) then
            New_Line;
            Start_Of_Line := True;
         end if;
      end loop;
      Close (Handle);
      if not First then
         Put_Line (Prefix & "====================");
      end if;
   exception
      when Name_Error =>
         -- Missing output file is ok.
         Put_Line (Prefix & "no output");
   end Print_Log_File;

   procedure Add_Pass (Listener : in out Tap_Listener;
                       Info     :        Context) is
   begin
      if Listener.Capture_Output then
         Temporary_Output.Restore_Output;
         Temporary_Output.Close_Temp (Listener.Output_File);
      end if;

      Put ("ok ");
      Put (Count_Image (Listener.Current_Test) & " ");
      Put (To_String (Info.Test_Name) & ": " & To_String (Info.Routine_Name));
      New_Line;
   end Add_Pass;

   procedure Report_Not_Ok (Listener : in out Tap_Listener;
                            Info     :        Context;
                            Severity :        String) is
      pragma Unreferenced (Severity);
   begin
      if Listener.Capture_Output then
         Temporary_Output.Restore_Output;
         Temporary_Output.Close_Temp (Listener.Output_File);
      end if;

      Put ("not ok ");
      Put (Count_Image (Listener.Current_Test) & " ");
      Put (To_String (Info.Test_Name) & ": " & To_String (Info.Routine_Name));
      New_Line;

      if Listener.Verbose then
         Print_Info (Info);
         if Listener.Capture_Output then
            Print_Log_File
              (Filename => Temporary_Output.Get_Name (Listener.Output_File),
               Prefix   => "# ");
         end if;
      end if;
   end Report_Not_Ok;

   procedure Add_Failure (Listener : in out Tap_Listener;
                          Info     :        Context) is
   begin
      Report_Not_Ok (Listener, Info, "fail");
   end Add_Failure;

   procedure Add_Error (Listener : in out Tap_Listener;
                        Info     :        Context) is
   begin
      Report_Not_Ok (Listener, Info, "error");
   end Add_Error;

   procedure Add_Skipped (Listener : in out Tap_Listener;
                          Info     :        Context) is
   begin
      if Listener.Capture_Output then
         Temporary_Output.Restore_Output;
         Temporary_Output.Close_Temp (Listener.Output_File);
      end if;

      Put ("ok ");
      Put (Count_Image (Listener.Current_Test) & " ");
      Put (To_String (Info.Test_Name) & ": " & To_String (Info.Routine_Name));
      Put (" # SKIP " & To_String (Info.Message));
      New_Line;
   end Add_Skipped;

   procedure Start_Test (Listener : in out Tap_Listener;
                         Info     :        Context) is
   begin
      if Info.Test_Kind = ROUTINE then
         Listener.Current_Test := Listener.Current_Test + 1;
         if Listener.Capture_Output then
            Temporary_Output.Create_Temp (Listener.Output_File);
            Temporary_Output.Redirect_Output (Listener.Output_File);
         end if;
      end if;
   end Start_Test;

   procedure End_Test (Listener : in out Tap_Listener;
                       Info     :        Context) is
      pragma Unreferenced (Info);

      Handle : Ada.Text_IO.File_Type;
   begin
      if Listener.Capture_Output then
         Ada.Text_IO.Open (Handle, Ada.Text_IO.Out_File,
                           Temporary_Output.Get_Name (Listener.Output_File));
         Ada.Text_IO.Delete (Handle);
      end if;
   exception
      when Name_Error =>
         -- Missing file is safe to ignore, we are going to delete it anyway
         null;
   end End_Test;
end Ahven.Tap_Runner;

Fix compilation warning

Fix compilation warning


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

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

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

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

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

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

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

end Util.Streams.Buffered.Lzma;

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

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

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

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

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

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

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

end Util.Streams.Buffered.Lzma;

Fix the test to write the output buffer when it becomes full


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

      --  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.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 (2.0);
      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;

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

Add Test_Http_Timeout and register the test for execution


-----------------------------------------------------------------------
--  awa-images-services -- Image service
--  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 Util.Processes;
with Util.Beans.Objects;
with Util.Log.Loggers;
with Util.Streams.Pipes;
with Util.Streams.Texts;

with ADO.Sessions;

with AWA.Images.Models;
with AWA.Services.Contexts;
with AWA.Storages.Services;
with AWA.Storages.Modules;
with Ada.Strings.Unbounded;

with EL.Variables.Default;
with EL.Contexts.Default;

--  == Storage Service ==
--  The <tt>Storage_Service</tt> provides the operations to access and use the persisent storage.
--  It controls the permissions that grant access to the service for users.
--
--  Other modules can be notified of storage changes by registering a listener
--  on the storage module.
package body AWA.Images.Services is

   package ASC renames Awa.Services.Contexts;

   --  ------------------------------
   --  Image Service
   --  ------------------------------

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("AWA.Images.Services");

   --  ------------------------------
   --  Initializes the storage service.
   --  ------------------------------
   overriding
   procedure Initialize (Service : in out Image_Service;
                         Module  : in AWA.Modules.Module'Class) is
   begin
      AWA.Modules.Module_Manager (Service).Initialize (Module);

      declare
         Ctx     : EL.Contexts.Default.Default_Context;
         Command : constant String := Module.Get_Config (PARAM_THUMBNAIL_COMMAND);
      begin
         Service.Thumbnail_Command := EL.Expressions.Create_Expression (Command, Ctx);

      exception
         when E : others =>
            Log.Error ("Invalid thumbnail command: ", E, True);
      end;
   end Initialize;

   procedure Create_Thumbnail (Service : in Image_Service;
                               Source  : in String;
                               Into    : in String;
                               Width   : out Natural;
                               Height  : out Natural) is
      Ctx       : EL.Contexts.Default.Default_Context;
      Variables : aliased EL.Variables.Default.Default_Variable_Mapper;

      Proc    : Util.Processes.Process;
      Pipe    : aliased Util.Streams.Pipes.Pipe_Stream;
   begin
      Variables.Bind ("src", Util.Beans.Objects.To_Object (Source));
      Variables.Bind ("dst", Util.Beans.Objects.To_Object (Into));
      Ctx.Set_Variable_Mapper (Variables'Unchecked_Access);
      declare
         Cmd     : constant Util.Beans.Objects.Object := Service.Thumbnail_Command.Get_Value (Ctx);
         Command : constant String := Util.Beans.Objects.To_String (Cmd);
         Input   : Util.Streams.Texts.Reader_Stream;
      begin
         Width  := 0;
         Height := 0;
         Pipe.Open (Command, Util.Processes.READ);
         Input.Initialize (null, Pipe'Unchecked_Access, 1024);
         while not Input.Is_Eof loop
            declare
               Line : Ada.Strings.Unbounded.Unbounded_String;
               Pos  : Natural;
               Sep  : Natural;
               Last : Natural;
            begin
               Input.Read_Line (Into  => Line, Strip => False);
               exit when Ada.Strings.Unbounded.Length (Line) = 0;
               Log.Info ("Received: {0}", Line);

               --  The '-verbose' option of ImageMagick reports information about the original
               --  image.  Extract the picture width and height.
               --  image.png PNG 120x282 120x282+0+0 8-bit DirectClass 34.4KB 0.000u 0:00.018
               Pos := Ada.Strings.Unbounded.Index (Line, " ");
               if Pos > 0 and Width = 0 then
                  Pos := Ada.Strings.Unbounded.Index (Line, " ", Pos + 1);
                  if Pos > 0 then
                     Sep := Ada.Strings.Unbounded.Index (Line, "x", Pos + 1);
                     Last := Ada.Strings.Unbounded.Index (Line, " ", Pos + 1);
                     if Sep > 0 and Sep < Last then
                        Width := Natural'Value (Ada.Strings.Unbounded.Slice (Line, Pos + 1, Sep - 1));
                        Height := Natural'Value (Ada.Strings.Unbounded.Slice (Line, Sep + 1, Last - 1));
                     end if;
                  end if;
               end if;
            end;
         end loop;
         Pipe.Close;

         Util.Processes.Wait (Proc);
         if Pipe.Get_Exit_Status /= 0 then
            Log.Error ("Command {0} exited with status {1}", Command,
                       Integer'Image (Pipe.Get_Exit_Status));
         end if;
      end;
   end Create_Thumbnail;

   --  Save the data object contained in the Data part element into the
   --  target storage represented by Into.
   procedure Build_Thumbnail (Service : in Image_Service;
                              Id      : in ADO.Identifier;
                              File    : in AWA.Storages.Models.Storage_Ref'Class) is

      Storage_Service : constant AWA.Storages.Services.Storage_Service_Access := AWA.Storages.Modules.Get_Storage_Manager;
      Ctx         : constant ASC.Service_Context_Access := ASC.Current;
      DB          : ADO.Sessions.Master_Session := ASC.Get_Master_Session (Ctx);
      Img         : AWA.Images.Models.Image_Ref;
      Local_Path  : Ada.Strings.Unbounded.Unbounded_String;
      Target_File : AWA.Storages.Storage_File;
      Local_File  : AWA.Storages.Storage_File;
      Width       : Natural;
      Height      : Natural;
   begin
      Img.Load (DB, Id);
      Storage_Service.Get_Local_File (From => Img.Get_Storage.Get_Id, Into => Local_File);
      Storage_Service.Create_Local_File (Target_File);
      Service.Create_Thumbnail (AWA.Storages.Get_Path (Local_File),
                                AWA.Storages.Get_Path (Target_File), Width, Height);
      Img.Set_Width (Width);
      Img.Set_Height (Height);
      Img.Set_Thumb_Width (64);
      Img.Set_Thumb_Height (64);
      Ctx.Start;
      Img.Save (DB);
--        Storage_Service.Save (Target_File);
      Ctx.Commit;
   end Build_Thumbnail;

   --  Save the data object contained in the Data part element into the
   --  target storage represented by Into.
   procedure Create_Image (Service : in Image_Service;
                           File    : in AWA.Storages.Models.Storage_Ref'Class) is
      Ctx : constant AWA.Services.Contexts.Service_Context_Access := AWA.Services.Contexts.Current;
      DB  : ADO.Sessions.Master_Session := AWA.Services.Contexts.Get_Master_Session (Ctx);
      Img : AWA.Images.Models.Image_Ref;
   begin
      Ctx.Start;
      Img.Set_Width (0);
      Img.Set_Height (0);
      Img.Set_Thumb_Height (0);
      Img.Set_Thumb_Width (0);
      Img.Set_Storage (File);
      Img.Save (DB);
      Ctx.Commit;
   end Create_Image;

   --  Deletes the storage instance.
   procedure Delete_Image (Service : in Image_Service;
                           File    : in AWA.Storages.Models.Storage_Ref'Class) is
   begin
      null;
   end Delete_Image;

end AWA.Images.Services;

-----------------------------------------------------------------------
--  awa-images-services -- Image service
--  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 Util.Processes;
with Util.Beans.Objects;
with Util.Log.Loggers;
with Util.Streams.Pipes;
with Util.Streams.Texts;

with ADO.Sessions;

with AWA.Images.Models;
with AWA.Services.Contexts;
with AWA.Storages.Services;
with AWA.Storages.Modules;
with Ada.Strings.Unbounded;

with EL.Variables.Default;
with EL.Contexts.Default;

--  == Storage Service ==
--  The <tt>Storage_Service</tt> provides the operations to access and use the persisent storage.
--  It controls the permissions that grant access to the service for users.
--
--  Other modules can be notified of storage changes by registering a listener
--  on the storage module.
package body AWA.Images.Services is

   package ASC renames Awa.Services.Contexts;

   --  ------------------------------
   --  Image Service
   --  ------------------------------

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("AWA.Images.Services");

   --  ------------------------------
   --  Initializes the storage service.
   --  ------------------------------
   overriding
   procedure Initialize (Service : in out Image_Service;
                         Module  : in AWA.Modules.Module'Class) is
   begin
      AWA.Modules.Module_Manager (Service).Initialize (Module);

      declare
         Ctx     : EL.Contexts.Default.Default_Context;
         Command : constant String := Module.Get_Config (PARAM_THUMBNAIL_COMMAND);
      begin
         Service.Thumbnail_Command := EL.Expressions.Create_Expression (Command, Ctx);

      exception
         when E : others =>
            Log.Error ("Invalid thumbnail command: ", E, True);
      end;
   end Initialize;

   procedure Create_Thumbnail (Service : in Image_Service;
                               Source  : in String;
                               Into    : in String;
                               Width   : out Natural;
                               Height  : out Natural) is
      Ctx       : EL.Contexts.Default.Default_Context;
      Variables : aliased EL.Variables.Default.Default_Variable_Mapper;

      Proc    : Util.Processes.Process;
      Pipe    : aliased Util.Streams.Pipes.Pipe_Stream;
   begin
      Variables.Bind ("src", Util.Beans.Objects.To_Object (Source));
      Variables.Bind ("dst", Util.Beans.Objects.To_Object (Into));
      Ctx.Set_Variable_Mapper (Variables'Unchecked_Access);
      declare
         Cmd     : constant Util.Beans.Objects.Object := Service.Thumbnail_Command.Get_Value (Ctx);
         Command : constant String := Util.Beans.Objects.To_String (Cmd);
         Input   : Util.Streams.Texts.Reader_Stream;
      begin
         Width  := 0;
         Height := 0;
         Pipe.Open (Command, Util.Processes.READ);
         Input.Initialize (null, Pipe'Unchecked_Access, 1024);
         while not Input.Is_Eof loop
            declare
               Line : Ada.Strings.Unbounded.Unbounded_String;
               Pos  : Natural;
               Sep  : Natural;
               Last : Natural;
            begin
               Input.Read_Line (Into  => Line, Strip => False);
               exit when Ada.Strings.Unbounded.Length (Line) = 0;
               Log.Info ("Received: {0}", Line);

               --  The '-verbose' option of ImageMagick reports information about the original
               --  image.  Extract the picture width and height.
               --  image.png PNG 120x282 120x282+0+0 8-bit DirectClass 34.4KB 0.000u 0:00.018
               Pos := Ada.Strings.Unbounded.Index (Line, " ");
               if Pos > 0 and Width = 0 then
                  Pos := Ada.Strings.Unbounded.Index (Line, " ", Pos + 1);
                  if Pos > 0 then
                     Sep := Ada.Strings.Unbounded.Index (Line, "x", Pos + 1);
                     Last := Ada.Strings.Unbounded.Index (Line, "=", Pos + 1);
                     if Sep > 0 and Sep < Last then
                        Log.Info ("Dimension {0} - {1}..{2}",
                                  Ada.Strings.Unbounded.Slice (Line, Pos, Last),
                                  Natural'Image (Pos), Natural'Image (Last));
                        Width := Natural'Value (Ada.Strings.Unbounded.Slice (Line, Pos + 1, Sep - 1));
                        Height := Natural'Value (Ada.Strings.Unbounded.Slice (Line, Sep + 1, Last - 1));
                     end if;
                  end if;
               end if;
            end;
         end loop;
         Pipe.Close;

         Util.Processes.Wait (Proc);
         if Pipe.Get_Exit_Status /= 0 then
            Log.Error ("Command {0} exited with status {1}", Command,
                       Integer'Image (Pipe.Get_Exit_Status));
         end if;
      end;
   end Create_Thumbnail;

   --  Save the data object contained in the Data part element into the
   --  target storage represented by Into.
   procedure Build_Thumbnail (Service : in Image_Service;
                              Id      : in ADO.Identifier;
                              File    : in AWA.Storages.Models.Storage_Ref'Class) is

      Storage_Service : constant AWA.Storages.Services.Storage_Service_Access := AWA.Storages.Modules.Get_Storage_Manager;
      Ctx         : constant ASC.Service_Context_Access := ASC.Current;
      DB          : ADO.Sessions.Master_Session := ASC.Get_Master_Session (Ctx);
      Img         : AWA.Images.Models.Image_Ref;
      Local_Path  : Ada.Strings.Unbounded.Unbounded_String;
      Target_File : AWA.Storages.Storage_File;
      Local_File  : AWA.Storages.Storage_File;
      Width       : Natural;
      Height      : Natural;
   begin
      Img.Load (DB, Id);
      Storage_Service.Get_Local_File (From => Img.Get_Storage.Get_Id, Into => Local_File);
      Storage_Service.Create_Local_File (Target_File);
      Service.Create_Thumbnail (AWA.Storages.Get_Path (Local_File),
                                AWA.Storages.Get_Path (Target_File), Width, Height);
      Img.Set_Width (Width);
      Img.Set_Height (Height);
      Img.Set_Thumb_Width (64);
      Img.Set_Thumb_Height (64);
      Ctx.Start;
      Img.Save (DB);
--        Storage_Service.Save (Target_File);
      Ctx.Commit;
   end Build_Thumbnail;

   --  Save the data object contained in the Data part element into the
   --  target storage represented by Into.
   procedure Create_Image (Service : in Image_Service;
                           File    : in AWA.Storages.Models.Storage_Ref'Class) is
      Ctx : constant AWA.Services.Contexts.Service_Context_Access := AWA.Services.Contexts.Current;
      DB  : ADO.Sessions.Master_Session := AWA.Services.Contexts.Get_Master_Session (Ctx);
      Img : AWA.Images.Models.Image_Ref;
   begin
      Ctx.Start;
      Img.Set_Width (0);
      Img.Set_Height (0);
      Img.Set_Thumb_Height (0);
      Img.Set_Thumb_Width (0);
      Img.Set_Storage (File);
      Img.Save (DB);
      Ctx.Commit;
   end Create_Image;

   --  Deletes the storage instance.
   procedure Delete_Image (Service : in Image_Service;
                           File    : in AWA.Storages.Models.Storage_Ref'Class) is
   begin
      null;
   end Delete_Image;

end AWA.Images.Services;

Fix extraction of image dimension

Fix extraction of image dimension


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

   --  ------------------------------
   --  Execute the wifi 'status' command to print the Wifi current status.
   --  ------------------------------
   procedure Do_List (Command   : in Command_Type;
                      Args      : in Argument_List'Class;
                      Selector  : in Device_Selector_Type;
                      Context   : in out Context_Type) is
      pragma Unreferenced (Command, Args);
      procedure Box_Status (Gateway : in out Druss.Gateways.Gateway_Type);

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

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

         procedure Print_Device (Manager : in Util.Properties.Manager;
                                 Name    : in String) is
            Link : constant String := Manager.Get (Name & ".link", "");
            Kind : constant String := Manager.Get (Name & ".devicetype", "");
         begin
            case Selector is
               when DEVICE_ALL =>
                  null;

               when DEVICE_ACTIVE =>
                  if Manager.Get (Name & ".active", "") = "0" then
                     return;
                  end if;

               when DEVICE_INACTIVE =>
                  if Manager.Get (Name & ".active", "") = "1" then
                     return;
                  end if;

            end case;

            Console.Start_Row;
            Console.Print_Field (F_BBOX_IP_ADDR, Gateway.Ip);
            Console.Print_Field (F_IP_ADDR, Manager.Get (Name & ".ipaddress", ""));
            Console.Print_Field (F_ETHERNET, Manager.Get (Name & ".macaddress", ""));
            Console.Print_Field (F_HOSTNAME, Manager.Get (Name & ".hostname", ""));
            Console.Print_Field (F_ACTIVE, Manager.Get (Name & ".active", ""));
            Console.Print_Field (F_DEVTYPE, (if Kind = "STB" then "STB" else ""));
            if Link = "Ethernet" then
               Console.Print_Field (F_LINK, Link & " port "
                                    & Manager.Get (Name & ".ethernet.logicalport", ""));
            else
               Console.Print_Field (F_LINK, Link & " RSSI "
                                    & Manager.Get (Name & ".wireless.rssi0", ""));
            end if;
            Console.End_Row;
         end Print_Device;

      begin
         Gateway.Refresh;

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

   begin
      Console.Start_Title;
      Console.Print_Title (F_BBOX_IP_ADDR, "Bbox IP", 16);
      Console.Print_Title (F_IP_ADDR, "Device IP", 16);
      Console.Print_Title (F_ETHERNET, "Ethernet", 20);
      Console.Print_Title (F_HOSTNAME, "Hostname", 28);
      Console.Print_Title (F_DEVTYPE, "Type", 6);
      --  Console.Print_Title (F_ACTIVE, "Active", 8);
      Console.Print_Title (F_LINK, "Link", 18);
      Console.End_Title;
      Druss.Gateways.Iterate (Context.Gateways, Gateways.ITER_ENABLE, Box_Status'Access);
   end Do_List;

   --  ------------------------------
   --  Execute a status command to report information about the Bbox.
   --  ------------------------------
   overriding
   procedure Execute (Command   : in out Command_Type;
                      Name      : in String;
                      Args      : in Argument_List'Class;
                      Context   : in out Context_Type) is
      pragma Unreferenced (Name);
   begin
     if Args.Get_Count > 1 then
         Context.Console.Notice (N_USAGE, "Too many arguments to the command");
         Druss.Commands.Driver.Usage (Args);
      elsif Args.Get_Count = 0 then
         Command.Do_List (Args, DEVICE_ACTIVE, Context);
      elsif Args.Get_Argument (1) = "all" then
         Command.Do_List (Args, DEVICE_ALL, Context);
      elsif Args.Get_Argument (1) = "active" then
         Command.Do_List (Args, DEVICE_ACTIVE, Context);
      elsif Args.Get_Argument (1) = "inactive" then
         Command.Do_List (Args, DEVICE_INACTIVE, Context);
      else
         Context.Console.Notice (N_USAGE, "Invalid argument: " & Args.Get_Argument (1));
         Druss.Commands.Driver.Usage (Args);
      end if;
   end Execute;

   --  ------------------------------
   --  Write the help associated with the command.
   --  ------------------------------
   overriding
   procedure Help (Command   : in Command_Type;
                   Context   : in out Context_Type) is
      pragma Unreferenced (Command);
      Console : constant Druss.Commands.Consoles.Console_Access := Context.Console;
   begin
      Console.Notice (N_HELP, "devices: Print information about the devices");
      Console.Notice (N_HELP, "Usage: devices [all | active | inactive]");
      Console.Notice (N_HELP, "");
      Console.Notice (N_HELP, "  List the devices that are known by the Bbox.");
      Console.Notice (N_HELP, "");
      Console.Notice (N_HELP, "    all        List all the devices");
      Console.Notice (N_HELP, "    active     List the active devices (the default)");
      Console.Notice (N_HELP, "    inative    List the inactive devices");
   end Help;

end Druss.Commands.Devices;

-----------------------------------------------------------------------
--  druss-commands-devices -- Print information about the devices
--  Copyright (C) 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 Util.Properties;
with Bbox.API;
with Druss.Gateways;
package body Druss.Commands.Devices is

   --  ------------------------------
   --  Execute the wifi 'status' command to print the Wifi current status.
   --  ------------------------------
   procedure Do_List (Command   : in Command_Type;
                      Args      : in Argument_List'Class;
                      Selector  : in Device_Selector_Type;
                      Context   : in out Context_Type) is
      pragma Unreferenced (Command, Args);
      procedure Box_Status (Gateway : in out Druss.Gateways.Gateway_Type);

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

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

         procedure Print_Device (Manager : in Util.Properties.Manager;
                                 Name    : in String) is
            Link : constant String := Manager.Get (Name & ".link", "");
            Kind : constant String := Manager.Get (Name & ".devicetype", "");
         begin
            case Selector is
               when DEVICE_ALL =>
                  null;

               when DEVICE_ACTIVE =>
                  if Manager.Get (Name & ".active", "") = "0" then
                     return;
                  end if;

               when DEVICE_INACTIVE =>
                  if Manager.Get (Name & ".active", "") = "1" then
                     return;
                  end if;

            end case;

            Console.Start_Row;
            Console.Print_Field (F_BBOX_IP_ADDR, Gateway.Ip);
            Console.Print_Field (F_IP_ADDR, Manager.Get (Name & ".ipaddress", ""));
            Console.Print_Field (F_ETHERNET, Manager.Get (Name & ".macaddress", ""));
            Console.Print_Field (F_HOSTNAME, Manager.Get (Name & ".hostname", ""));
            Console.Print_Field (F_ACTIVE, Manager.Get (Name & ".active", ""));
            Console.Print_Field (F_DEVTYPE, (if Kind = "STB" then "STB" else ""));
            if Link = "Ethernet" then
               Console.Print_Field (F_LINK, Link & " port "
                                    & Manager.Get (Name & ".ethernet.logicalport", ""));
            else
               Console.Print_Field (F_LINK, Link & " RSSI "
                                    & Manager.Get (Name & ".wireless.rssi0", ""));
            end if;
            Console.End_Row;
         end Print_Device;

      begin
         Gateway.Refresh;

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

   begin
      Console.Start_Title;
      Console.Print_Title (F_BBOX_IP_ADDR, "Bbox IP", 16);
      Console.Print_Title (F_IP_ADDR, "Device IP", 16);
      Console.Print_Title (F_ETHERNET, "Ethernet", 20);
      Console.Print_Title (F_HOSTNAME, "Hostname", 28);
      Console.Print_Title (F_DEVTYPE, "Type", 6);
      --  Console.Print_Title (F_ACTIVE, "Active", 8);
      Console.Print_Title (F_LINK, "Link", 18);
      Console.End_Title;
      Druss.Gateways.Iterate (Context.Gateways, Gateways.ITER_ENABLE, Box_Status'Access);
   end Do_List;

   --  ------------------------------
   --  Execute a status command to report information about the Bbox.
   --  ------------------------------
   overriding
   procedure Execute (Command   : in out Command_Type;
                      Name      : in String;
                      Args      : in Argument_List'Class;
                      Context   : in out Context_Type) is
      pragma Unreferenced (Name);
   begin
      if Args.Get_Count > 1 then
         Context.Console.Notice (N_USAGE, "Too many arguments to the command");
         Druss.Commands.Driver.Usage (Args, Context);
      elsif Args.Get_Count = 0 then
         Command.Do_List (Args, DEVICE_ACTIVE, Context);
      elsif Args.Get_Argument (1) = "all" then
         Command.Do_List (Args, DEVICE_ALL, Context);
      elsif Args.Get_Argument (1) = "active" then
         Command.Do_List (Args, DEVICE_ACTIVE, Context);
      elsif Args.Get_Argument (1) = "inactive" then
         Command.Do_List (Args, DEVICE_INACTIVE, Context);
      else
         Context.Console.Notice (N_USAGE, "Invalid argument: " & Args.Get_Argument (1));
         Druss.Commands.Driver.Usage (Args, Context);
      end if;
   end Execute;

   --  ------------------------------
   --  Write the help associated with the command.
   --  ------------------------------
   overriding
   procedure Help (Command   : in out Command_Type;
                   Context   : in out Context_Type) is
      pragma Unreferenced (Command);
      Console : constant Druss.Commands.Consoles.Console_Access := Context.Console;
   begin
      Console.Notice (N_HELP, "devices: Print information about the devices");
      Console.Notice (N_HELP, "Usage: devices [all | active | inactive]");
      Console.Notice (N_HELP, "");
      Console.Notice (N_HELP, "  List the devices that are known by the Bbox.");
      Console.Notice (N_HELP, "");
      Console.Notice (N_HELP, "    all        List all the devices");
      Console.Notice (N_HELP, "    active     List the active devices (the default)");
      Console.Notice (N_HELP, "    inative    List the inactive devices");
   end Help;

end Druss.Commands.Devices;

Change Help command to accept in out command