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

   type Request is new ASF.Requests.Request with private;
   type Request_Access is access all Request'Class;

   function Get_Parameter (R : Request; Name : String) return String;

   --  Set the AWS data received to initialize the request object.
   procedure Set_Request (Req  : in out Request;
                          Data : access AWS.Status.Data);

   --  Returns the name of the HTTP method with which this request was made,
   --  for example, GET, POST, or PUT. Same as the value of the CGI variable
   --  REQUEST_METHOD.
   function Get_Method (Req : in Request) return String;

   --  Returns the name and version of the protocol the request uses in the form
   --  protocol/majorVersion.minorVersion, for example, HTTP/1.1. For HTTP servlets,
   --  the value returned is the same as the value of the CGI variable SERVER_PROTOCOL.
   function Get_Protocol (Req : in Request) return String;

   --  Returns the part of this request's URL from the protocol name up to the query
   --  string in the first line of the HTTP request. The web container does not decode
   --  this String. For example:
   --  First line of HTTP request    Returned Value
   --  POST /some/path.html HTTP/1.1        /some/path.html
   --  GET http://foo.bar/a.html HTTP/1.0       /a.html
   --  HEAD /xyz?a=b HTTP/1.1       /xyz
   function Get_Request_URI (Req : in Request) return String;

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

   --  Returns all the values of the specified request header as an Enumeration
   --  of String objects.
   --
   --  Some headers, such as Accept-Language can be sent by clients as several headers
   --  each with a different value rather than sending the header as a comma
   --  separated list.
   --
   --  If the request did not include any headers of the specified name, this method
   --  returns an empty Enumeration. The header name is case insensitive. You can use
   --  this method with any request header.
   function Get_Headers (Req  : in Request;
                         Name : in String) return String;

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

   --  Returns the Internet Protocol (IP) address of the client or last proxy that
   --  sent the request. For HTTP servlets, same as the value of the CGI variable
   --  REMOTE_ADDR.
   function Get_Remote_Addr (Req : in Request) return String;

   --  Get the number of parts included in the request.
   function Get_Part_Count (Req : in Request) return Natural;

   --  Process the part at the given position and executes the Process operation
   --  with the part object.
   procedure Process_Part (Req      : in out Request;
                           Position : in Positive;
                           Process  : not null access
                             procedure (Data : in ASF.Parts.Part'Class));

   --  Process the part identifed by Id and executes the Process operation
   --  with the part object.
   procedure Process_Part (Req      : in out Request;
                           Id       : in String;
                           Process  : not null access
                             procedure (Data : in ASF.Parts.Part'Class));
private

   type Request is new ASF.Requests.Request with record
      Data    : access AWS.Status.Data;
      Headers : AWS.Headers.List;
   end record;

end ASF.Requests.Web;

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

   type Request is new ASF.Requests.Request with private;
   type Request_Access is access all Request'Class;

   function Get_Parameter (R : Request; Name : String) return String;

   --  Set the AWS data received to initialize the request object.
   procedure Set_Request (Req  : in out Request;
                          Data : access AWS.Status.Data);

   --  Returns the name of the HTTP method with which this request was made,
   --  for example, GET, POST, or PUT. Same as the value of the CGI variable
   --  REQUEST_METHOD.
   function Get_Method (Req : in Request) return String;

   --  Returns the name and version of the protocol the request uses in the form
   --  protocol/majorVersion.minorVersion, for example, HTTP/1.1. For HTTP servlets,
   --  the value returned is the same as the value of the CGI variable SERVER_PROTOCOL.
   function Get_Protocol (Req : in Request) return String;

   --  Returns the part of this request's URL from the protocol name up to the query
   --  string in the first line of the HTTP request. The web container does not decode
   --  this String. For example:
   --  First line of HTTP request    Returned Value
   --  POST /some/path.html HTTP/1.1        /some/path.html
   --  GET http://foo.bar/a.html HTTP/1.0       /a.html
   --  HEAD /xyz?a=b HTTP/1.1       /xyz
   function Get_Request_URI (Req : in Request) return String;

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

   --  Returns all the values of the specified request header as an Enumeration
   --  of String objects.
   --
   --  Some headers, such as Accept-Language can be sent by clients as several headers
   --  each with a different value rather than sending the header as a comma
   --  separated list.
   --
   --  If the request did not include any headers of the specified name, this method
   --  returns an empty Enumeration. The header name is case insensitive. You can use
   --  this method with any request header.
   function Get_Headers (Req  : in Request;
                         Name : in String) return String;

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

   --  Returns the Internet Protocol (IP) address of the client or last proxy that
   --  sent the request. For HTTP servlets, same as the value of the CGI variable
   --  REMOTE_ADDR.
   function Get_Remote_Addr (Req : in Request) return String;

   --  Get the number of parts included in the request.
   function Get_Part_Count (Req : in Request) return Natural;

   --  Process the part at the given position and executes the Process operation
   --  with the part object.
   procedure Process_Part (Req      : in out Request;
                           Position : in Positive;
                           Process  : not null access
                             procedure (Data : in ASF.Parts.Part'Class));

   --  Process the part identifed by Id and executes the Process operation
   --  with the part object.
   procedure Process_Part (Req      : in out Request;
                           Id       : in String;
                           Process  : not null access
                             procedure (Data : in ASF.Parts.Part'Class));
private

   type Request is new ASF.Requests.Request with record
      Data    : access AWS.Status.Data;
      Headers : AWS.Headers.List;
   end record;

end ASF.Requests.Web;

Fix compilation warning

Fix compilation warning


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

with Util.Log.Loggers;
with Util.Strings.Transforms;
package body Gen.Commands.Project is

   use Util.Log;

   Log : constant Loggers.Logger := Loggers.Create ("Gen.Commands.Project");

   --  ------------------------------
   --  Generator Command
   --  ------------------------------
   function Get_Name_From_Email (Email : in String) return String;

   --  ------------------------------
   --  Get the user name from the email address.
   --  Returns the possible user name from his email address.
   --  ------------------------------
   function Get_Name_From_Email (Email : in String) return String is
      Pos : Natural := Util.Strings.Index (Email, '<');
   begin
      if Pos > 0 then
         return Email (Email'First .. Pos - 1);
      end if;
      Pos := Util.Strings.Index (Email, '@');
      if Pos > 0 then
         return Email (Email'First .. Pos - 1);
      else
         return Email;
      end if;
   end Get_Name_From_Email;

   --  ------------------------------
   --  Execute the command with the arguments.
   --  ------------------------------
   overriding
   procedure Execute (Cmd       : in Command;
                      Name      : in String;
                      Args      : in Argument_List'Class;
                      Generator : in out Gen.Generator.Handler) is
      pragma Unreferenced (Name, Args);
      use GNAT.Command_Line;

      Web_Flag  : aliased Boolean := False;
      Tool_Flag : aliased Boolean := False;
      Ado_Flag  : aliased Boolean := False;
      Gtk_Flag  : aliased Boolean := False;
   begin
      --  If a dynamo.xml file exists, read it.
      if Ada.Directories.Exists ("dynamo.xml") then
         Generator.Read_Project ("dynamo.xml");
      else
         Generator.Set_Project_Property ("license", "apache");
         Generator.Set_Project_Property ("author", "unknown");
         Generator.Set_Project_Property ("author_email", "unknown@company.com");
      end if;
      --  Parse the command line
      loop
         case Getopt ("l: ? -web -tool -ado -gtk") is
         when ASCII.NUL => exit;

         when '-' =>
            if Full_Switch = "-web" then
               Web_Flag := True;
            elsif Full_Switch = "-tool" then
               Tool_Flag := True;
            elsif Full_Switch = "-ado" then
               Ado_Flag := True;
            elsif Full_Switch = "-gtk" then
               Gtk_Flag := True;
            end if;

         when 'l' =>
            declare
               L : constant String := Util.Strings.Transforms.To_Lower_Case (Parameter);
            begin
               Log.Info ("License {0}", L);

               if L = "apache" then
                  Generator.Set_Project_Property ("license", "apache");
               elsif L = "gpl" then
                  Generator.Set_Project_Property ("license", "gpl");
               elsif L = "gpl3" then
                  Generator.Set_Project_Property ("license", "gpl3");
               elsif L = "mit" then
                  Generator.Set_Project_Property ("license", "mit");
               elsif L = "bsd3" then
                  Generator.Set_Project_Property ("license", "bsd3");
               elsif L = "proprietary" then
                  Generator.Set_Project_Property ("license", "proprietary");
               else
                  Generator.Error ("Invalid license: {0}", L);
                  Generator.Error ("Valid licenses: apache, gpl, gpl3, mit, bsd3, proprietary");
                  return;
               end if;
            end;

         when others =>
            null;
         end case;
      end loop;
      if not Web_Flag and not Ado_Flag and not Tool_Flag and not Gtk_Flag then
         Web_Flag := True;
      end if;
      declare
         Name  : constant String := Get_Argument;
         Arg2  : constant String := Get_Argument;
         Arg3  : constant String := Get_Argument;
      begin
         if Name'Length = 0 then
            Generator.Error ("Missing project name");
            Cmd.Usage;
            return;
         end if;

         if Util.Strings.Index (Arg2, '@') > Arg2'First then
            Generator.Set_Project_Property ("author_email", Arg2);
            if Arg3'Length = 0 then
               Generator.Set_Project_Property ("author", Get_Name_From_Email (Arg2));
            else
               Generator.Set_Project_Property ("author", Arg3);
            end if;

         elsif Util.Strings.Index (Arg3, '@') > Arg3'First then
            Generator.Set_Project_Property ("author", Arg2);
            Generator.Set_Project_Property ("author_email", Arg3);

         elsif Arg3'Length > 0 then
            Generator.Error ("The last argument should be the author's email address.");
            Cmd.Usage;
            return;
         end if;

         Generator.Set_Project_Property ("is_web", Boolean'Image (Web_Flag));
         Generator.Set_Project_Property ("is_tool", Boolean'Image (Tool_Flag));
         Generator.Set_Project_Property ("is_ado", Boolean'Image (Ado_Flag));
         Generator.Set_Project_Property ("is_gtk", Boolean'Image (Gtk_Flag));
         Generator.Set_Project_Name (Name);
         Generator.Set_Force_Save (False);
         if Ado_Flag then
            Gen.Generator.Generate_All (Generator, Gen.Artifacts.ITERATION_TABLE, "project-ado");
         elsif Gtk_Flag then
            Gen.Generator.Generate_All (Generator, Gen.Artifacts.ITERATION_TABLE, "project-gtk");
         else
            Gen.Generator.Generate_All (Generator, Gen.Artifacts.ITERATION_TABLE, "project");
         end if;

         Generator.Save_Project;
         declare
            use type GNAT.OS_Lib.String_Access;

            Path   : constant GNAT.OS_Lib.String_Access
              := GNAT.OS_Lib.Locate_Exec_On_Path ("autoconf");
            Args   : GNAT.OS_Lib.Argument_List (1 .. 0);
            Status : Boolean;
         begin
            if Path = null then
               Generator.Error ("The 'autoconf' tool was not found.  It is necessary to "
                                & "generate the configure script.");
               Generator.Error ("Install 'autoconf' or launch it manually.");
            else
               Ada.Directories.Set_Directory (Generator.Get_Result_Directory);
               Log.Info ("Executing {0}", Path.all);
               GNAT.OS_Lib.Spawn (Path.all, Args, Status);
               if not Status then
                  Generator.Error ("Execution of {0} failed", Path.all);
               end if;
            end if;
         end;
      end;
   end Execute;

   --  ------------------------------
   --  Write the help associated with the command.
   --  ------------------------------
   overriding
   procedure Help (Cmd       : in Command;
                   Generator : in out Gen.Generator.Handler) is
      pragma Unreferenced (Cmd, Generator);
      use Ada.Text_IO;
   begin
      Put_Line ("create-project: Create a new Ada Web Application project");
      Put_Line ("Usage: create-project [-l apache|gpl|gpl3|mit|bsd3|proprietary] [--web] [--tool]"
                & "[--ado] [--gtk] NAME [AUTHOR] [EMAIL]");
      New_Line;
      Put_Line ("  Creates a new AWA application with the name passed in NAME.");
      Put_Line ("  The application license is controlled with the -l option. ");
      Put_Line ("  License headers can use either the Apache, the MIT license, the BSD 3 clauses");
      Put_Line ("  license, the GNU licenses or a proprietary license.");
      Put_Line ("  The author's name and email addresses are also reported in generated files.");
      New_Line;
      Put_Line ("  --web   Generate a Web application (the default)");
      Put_Line ("  --tool  Generate a command line tool");
      Put_Line ("  --ado   Generate a database tool operation for ADO");
      Put_Line ("  --gtk   Generate a GtkAda project");
   end Help;

end Gen.Commands.Project;

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

with Util.Log.Loggers;
with Util.Strings.Transforms;
package body Gen.Commands.Project is

   use Util.Log;

   Log : constant Loggers.Logger := Loggers.Create ("Gen.Commands.Project");

   --  ------------------------------
   --  Generator Command
   --  ------------------------------
   function Get_Name_From_Email (Email : in String) return String;

   --  ------------------------------
   --  Get the user name from the email address.
   --  Returns the possible user name from his email address.
   --  ------------------------------
   function Get_Name_From_Email (Email : in String) return String is
      Pos : Natural := Util.Strings.Index (Email, '<');
   begin
      if Pos > 0 then
         return Email (Email'First .. Pos - 1);
      end if;
      Pos := Util.Strings.Index (Email, '@');
      if Pos > 0 then
         return Email (Email'First .. Pos - 1);
      else
         return Email;
      end if;
   end Get_Name_From_Email;

   --  ------------------------------
   --  Execute the command with the arguments.
   --  ------------------------------
   overriding
   procedure Execute (Cmd       : in Command;
                      Name      : in String;
                      Args      : in Argument_List'Class;
                      Generator : in out Gen.Generator.Handler) is
      pragma Unreferenced (Name, Args);
      use GNAT.Command_Line;

      Web_Flag  : aliased Boolean := False;
      Tool_Flag : aliased Boolean := False;
      Ado_Flag  : aliased Boolean := False;
      Gtk_Flag  : aliased Boolean := False;
      Lib_Flag  : aliased Boolean := False;
   begin
      --  If a dynamo.xml file exists, read it.
      if Ada.Directories.Exists ("dynamo.xml") then
         Generator.Read_Project ("dynamo.xml");
      else
         Generator.Set_Project_Property ("license", "apache");
         Generator.Set_Project_Property ("author", "unknown");
         Generator.Set_Project_Property ("author_email", "unknown@company.com");
      end if;
      --  Parse the command line
      loop
         case Getopt ("l: ? -web -tool -ado -gtk") is
         when ASCII.NUL => exit;

         when '-' =>
            if Full_Switch = "-web" then
               Web_Flag := True;
            elsif Full_Switch = "-tool" then
               Tool_Flag := True;
            elsif Full_Switch = "-ado" then
               Ado_Flag := True;
            elsif Full_Switch = "-lib" then
               Lib_Flag := True;
            elsif Full_Switch = "-gtk" then
               Gtk_Flag := True;
            end if;

         when 'l' =>
            declare
               L : constant String := Util.Strings.Transforms.To_Lower_Case (Parameter);
            begin
               Log.Info ("License {0}", L);

               if L = "apache" then
                  Generator.Set_Project_Property ("license", "apache");
               elsif L = "gpl" then
                  Generator.Set_Project_Property ("license", "gpl");
               elsif L = "gpl3" then
                  Generator.Set_Project_Property ("license", "gpl3");
               elsif L = "mit" then
                  Generator.Set_Project_Property ("license", "mit");
               elsif L = "bsd3" then
                  Generator.Set_Project_Property ("license", "bsd3");
               elsif L = "proprietary" then
                  Generator.Set_Project_Property ("license", "proprietary");
               else
                  Generator.Error ("Invalid license: {0}", L);
                  Generator.Error ("Valid licenses: apache, gpl, gpl3, mit, bsd3, proprietary");
                  return;
               end if;
            end;

         when others =>
            null;
         end case;
      end loop;
      if not Web_Flag and not Ado_Flag and not Tool_Flag and not Gtk_Flag then
         Web_Flag := True;
      end if;
      declare
         Name  : constant String := Get_Argument;
         Arg2  : constant String := Get_Argument;
         Arg3  : constant String := Get_Argument;
      begin
         if Name'Length = 0 then
            Generator.Error ("Missing project name");
            Cmd.Usage;
            return;
         end if;

         if Util.Strings.Index (Arg2, '@') > Arg2'First then
            Generator.Set_Project_Property ("author_email", Arg2);
            if Arg3'Length = 0 then
               Generator.Set_Project_Property ("author", Get_Name_From_Email (Arg2));
            else
               Generator.Set_Project_Property ("author", Arg3);
            end if;

         elsif Util.Strings.Index (Arg3, '@') > Arg3'First then
            Generator.Set_Project_Property ("author", Arg2);
            Generator.Set_Project_Property ("author_email", Arg3);

         elsif Arg3'Length > 0 then
            Generator.Error ("The last argument should be the author's email address.");
            Cmd.Usage;
            return;
         end if;

         Generator.Set_Project_Property ("is_web", Boolean'Image (Web_Flag));
         Generator.Set_Project_Property ("is_tool", Boolean'Image (Tool_Flag));
         Generator.Set_Project_Property ("is_ado", Boolean'Image (Ado_Flag));
         Generator.Set_Project_Property ("is_gtk", Boolean'Image (Gtk_Flag));
         Generator.Set_Project_Property ("is_lib", Boolean'Image (Lib_Flag));
         Generator.Set_Project_Name (Name);
         Generator.Set_Force_Save (False);
         if Ado_Flag then
            Gen.Generator.Generate_All (Generator, Gen.Artifacts.ITERATION_TABLE, "project-ado");
         elsif Gtk_Flag then
            Gen.Generator.Generate_All (Generator, Gen.Artifacts.ITERATION_TABLE, "project-gtk");
         elsif Lib_Flag then
            Gen.Generator.Generate_All (Generator, Gen.Artifacts.ITERATION_TABLE, "project-lib");
         else
            Gen.Generator.Generate_All (Generator, Gen.Artifacts.ITERATION_TABLE, "project");
         end if;

         Generator.Save_Project;
         declare
            use type GNAT.OS_Lib.String_Access;

            Path   : constant GNAT.OS_Lib.String_Access
              := GNAT.OS_Lib.Locate_Exec_On_Path ("autoconf");
            Args   : GNAT.OS_Lib.Argument_List (1 .. 0);
            Status : Boolean;
         begin
            if Path = null then
               Generator.Error ("The 'autoconf' tool was not found.  It is necessary to "
                                & "generate the configure script.");
               Generator.Error ("Install 'autoconf' or launch it manually.");
            else
               Ada.Directories.Set_Directory (Generator.Get_Result_Directory);
               Log.Info ("Executing {0}", Path.all);
               GNAT.OS_Lib.Spawn (Path.all, Args, Status);
               if not Status then
                  Generator.Error ("Execution of {0} failed", Path.all);
               end if;
            end if;
         end;
      end;
   end Execute;

   --  ------------------------------
   --  Write the help associated with the command.
   --  ------------------------------
   overriding
   procedure Help (Cmd       : in Command;
                   Generator : in out Gen.Generator.Handler) is
      pragma Unreferenced (Cmd, Generator);
      use Ada.Text_IO;
   begin
      Put_Line ("create-project: Create a new Ada Web Application project");
      Put_Line ("Usage: create-project [-l apache|gpl|gpl3|mit|bsd3|proprietary] [--web] [--tool]"
                & "[--lib] [--ado] [--gtk] NAME [AUTHOR] [EMAIL]");
      New_Line;
      Put_Line ("  Creates a new AWA application with the name passed in NAME.");
      Put_Line ("  The application license is controlled with the -l option. ");
      Put_Line ("  License headers can use either the Apache, the MIT license, the BSD 3 clauses");
      Put_Line ("  license, the GNU licenses or a proprietary license.");
      Put_Line ("  The author's name and email addresses are also reported in generated files.");
      New_Line;
      Put_Line ("  --web   Generate a Web application (the default)");
      Put_Line ("  --tool  Generate a command line tool");
      Put_Line ("  --ado   Generate a database tool operation for ADO");
      Put_Line ("  --gtk   Generate a GtkAda project");
      Put_Line ("  --lib   Generate a library project");
   end Help;

end Gen.Commands.Project;

Add --lib option to the create-project command


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

with AWA.Users.Services.Tests;
with AWA.Users.Tests;
with AWA.Blogs.Modules.Tests;
with AWA.Blogs.Tests;
with AWA.Helpers.Selectors.Tests;
with AWA.Storages.Services.Tests;
with AWA.Events.Services.Tests;
with AWA.Mail.Clients.Tests;
with AWA.Mail.Modules.Tests;
with AWA.Images.Services.Tests;
with AWA.Votes.Modules.Tests;
with AWA.Tags.Modules.Tests;
with AWA.Questions.Modules.Tests;
with AWA.Counters.Modules.Tests;
with AWA.Modules.Tests;

with ASF.Converters.Dates;

with AWA.Users.Modules;
with AWA.Mail.Modules;
with AWA.Blogs.Modules;
with AWA.Workspaces.Modules;
with AWA.Storages.Modules;
with AWA.Images.Modules;
with AWA.Questions.Modules;
with AWA.Votes.Modules;
with AWA.Tags.Modules;
with AWA.Changelogs.Modules;
with AWA.Counters.Modules;

with AWA.Converters.Dates;
with AWA.Tests;
with AWA.Services.Contexts;
with AWA.Jobs.Services.Tests;
with AWA.Jobs.Modules.Tests;
with AWA.Settings.Modules.Tests;
with AWA.Comments.Modules.Tests;
with AWA.Changelogs.Modules.Tests;
with AWA.Wikis.Modules.Tests;

--  with ASF.Server.Web;
with ASF.Server.Tests;
package body AWA.Testsuite is
   Users          : aliased AWA.Users.Modules.User_Module;

   Workspaces     : aliased AWA.Workspaces.Modules.Workspace_Module;

   Mail           : aliased AWA.Mail.Modules.Mail_Module;

   Jobs           : aliased AWA.Jobs.Modules.Job_Module;

   Comments       : aliased AWA.Comments.Modules.Comment_Module;

   Blogs          : aliased AWA.Blogs.Modules.Blog_Module;

   Storages       : aliased AWA.Storages.Modules.Storage_Module;

   Images         : aliased AWA.Images.Modules.Image_Module;

   Questions      : aliased AWA.Questions.Modules.Question_Module;

   Votes          : aliased AWA.Votes.Modules.Vote_Module;

   Tags           : aliased AWA.Tags.Modules.Tag_Module;

   Settings       : aliased AWA.Settings.Modules.Setting_Module;

   Changelogs     : aliased AWA.Changelogs.Modules.Changelog_Module;

   Wikis          : aliased AWA.Wikis.Modules.Wiki_Module;

   Counters       : aliased AWA.Counters.Modules.Counter_Module;

   Date_Converter : aliased ASF.Converters.Dates.Date_Converter;

   Rel_Date_Converter : aliased AWA.Converters.Dates.Relative_Date_Converter;

   Tests : aliased Util.Tests.Test_Suite;

   function Suite return Util.Tests.Access_Test_Suite is
      Ret : constant Util.Tests.Access_Test_Suite := Tests'Access;
   begin
      AWA.Modules.Tests.Add_Tests (Ret);
      AWA.Events.Services.Tests.Add_Tests (Ret);
      AWA.Mail.Clients.Tests.Add_Tests (Ret);
      AWA.Mail.Modules.Tests.Add_Tests (Ret);
      AWA.Users.Services.Tests.Add_Tests (Ret);
      AWA.Users.Tests.Add_Tests (Ret);
      AWA.Counters.Modules.Tests.Add_Tests (Ret);
      AWA.Helpers.Selectors.Tests.Add_Tests (Ret);
      AWA.Jobs.Modules.Tests.Add_Tests (Ret);
      AWA.Jobs.Services.Tests.Add_Tests (Ret);
      AWA.Settings.Modules.Tests.Add_Tests (Ret);
      AWA.Comments.Modules.Tests.Add_Tests (Ret);
      AWA.Blogs.Modules.Tests.Add_Tests (Ret);
      AWA.Blogs.Tests.Add_Tests (Ret);
      AWA.Storages.Services.Tests.Add_Tests (Ret);
      AWA.Images.Services.Tests.Add_Tests (Ret);
      AWA.Changelogs.Modules.Tests.Add_Tests (Ret);
      AWA.Votes.Modules.Tests.Add_Tests (Ret);
      AWA.Tags.Modules.Tests.Add_Tests (Ret);
      AWA.Questions.Modules.Tests.Add_Tests (Ret);
      AWA.Wikis.Modules.Tests.Add_Tests (Ret);
      return Ret;
   end Suite;

   procedure Initialize (Props : in Util.Properties.Manager) is
   begin
      Initialize (null, Props, True);
   end Initialize;

   --  ------------------------------
   --  Initialize the AWA test framework mockup.
   --  ------------------------------
   procedure Initialize (App         : in AWA.Applications.Application_Access;
                         Props       : in Util.Properties.Manager;
                         Add_Modules : in Boolean) is
      use AWA.Applications;
   begin
      AWA.Tests.Initialize (App, Props, Add_Modules);

      if Add_Modules then
         declare
            Application : constant Applications.Application_Access := AWA.Tests.Get_Application;
            Ctx         : AWA.Services.Contexts.Service_Context;
            Users  : constant AWA.Users.Modules.User_Module_Access := AWA.Testsuite.Users'Access;
         begin
            Ctx.Set_Context (Application, null);
            Register (App    => Application.all'Access,
                      Name   => AWA.Users.Modules.NAME,
                      URI    => "user",
                      Module => Users.all'Access);

            Register (App    => Application.all'Access,
                      Name   => "mail",
                      URI    => "mail",
                      Module => Mail'Access);

            Register (App    => Application.all'Access,
                      Name   => "workspaces",
                      URI    => "workspaces",
                      Module => Workspaces'Access);

            Register (App    => Application.all'Access,
                      Name   => AWA.Counters.Modules.NAME,
                      URI    => "counters",
                      Module => Counters'Access);

            Register (App    => Application.all'Access,
                      Name   => AWA.Comments.Modules.NAME,
                      URI    => "comments",
                      Module => Comments'Access);

            Register (App    => Application.all'Access,
                      Name   => AWA.Storages.Modules.NAME,
                      URI    => "storages",
                      Module => Storages'Access);

            Register (App    => Application.all'Access,
                      Name   => AWA.Jobs.Modules.NAME,
                      URI    => "jobs",
                      Module => Jobs'Access);

            Register (App    => Application.all'Access,
                      Name   => AWA.Images.Modules.NAME,
                      URI    => "images",
                      Module => Images'Access);

            Register (App    => Application.all'Access,
                      Name   => AWA.Settings.Modules.NAME,
                      URI    => "settings",
                      Module => Settings'Access);

            Register (App    => Application.all'Access,
                      Name   => AWA.Votes.Modules.NAME,
                      URI    => "votes",
                      Module => Votes'Access);

            Register (App    => Application.all'Access,
                      Name   => AWA.Changelogs.Modules.NAME,
                      URI    => "changelogs",
                      Module => Changelogs'Access);

            Register (App    => Application.all'Access,
                      Name   => AWA.Tags.Modules.NAME,
                      URI    => "tags",
                      Module => Tags'Access);

            Register (App    => Application.all'Access,
                      Name   => AWA.Blogs.Modules.NAME,
                      URI    => "blogs",
                      Module => Blogs'Access);

            Register (App    => Application.all'Access,
                      Name   => AWA.Questions.Modules.NAME,
                      URI    => "questions",
                      Module => Questions'Access);

            Register (App    => Application.all'Access,
                      Name   => AWA.Wikis.Modules.NAME,
                      URI    => "wikis",
                      Module => Wikis'Access);

            Application.Add_Converter (Name      => "dateConverter",
                                       Converter => Date_Converter'Access);
            Application.Add_Converter (Name      => "smartDateConverter",
                                       Converter => Rel_Date_Converter'Access);
            Application.Start;
--              if Props.Exists ("test.server") then
--                 declare
--                    WS : ASF.Server.Web.AWS_Container;
--                 begin
--                    Application.Add_Converter (Name      => "dateConverter",
--                                               Converter => Date_Converter'Access);
--                    Application.Add_Converter (Name      => "smartDateConverter",
--                                               Converter => Rel_Date_Converter'Access);
--
--                    WS.Register_Application ("/asfunit", Application.all'Access);
--
--                    WS.Start;
--                    delay 6000.0;
--                 end;
--              end if;
            ASF.Server.Tests.Set_Context (Application.all'Access);
         end;
      end if;
   end Initialize;

end AWA.Testsuite;

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

with AWA.Users.Services.Tests;
with AWA.Users.Tests;
with AWA.Blogs.Modules.Tests;
with AWA.Blogs.Tests;
with AWA.Helpers.Selectors.Tests;
with AWA.Storages.Services.Tests;
with AWA.Events.Services.Tests;
with AWA.Mail.Clients.Tests;
with AWA.Mail.Modules.Tests;
with AWA.Images.Services.Tests;
with AWA.Votes.Modules.Tests;
with AWA.Tags.Modules.Tests;
with AWA.Questions.Modules.Tests;
with AWA.Counters.Modules.Tests;
with AWA.Workspaces.Tests;
with AWA.Modules.Tests;

with ASF.Converters.Dates;

with AWA.Users.Modules;
with AWA.Mail.Modules;
with AWA.Blogs.Modules;
with AWA.Workspaces.Modules;
with AWA.Storages.Modules;
with AWA.Images.Modules;
with AWA.Questions.Modules;
with AWA.Votes.Modules;
with AWA.Tags.Modules;
with AWA.Changelogs.Modules;
with AWA.Counters.Modules;

with AWA.Converters.Dates;
with AWA.Tests;
with AWA.Services.Contexts;
with AWA.Jobs.Services.Tests;
with AWA.Jobs.Modules.Tests;
with AWA.Settings.Modules.Tests;
with AWA.Comments.Modules.Tests;
with AWA.Changelogs.Modules.Tests;
with AWA.Wikis.Modules.Tests;

--  with ASF.Server.Web;
with ASF.Server.Tests;
package body AWA.Testsuite is
   Users          : aliased AWA.Users.Modules.User_Module;

   Workspaces     : aliased AWA.Workspaces.Modules.Workspace_Module;

   Mail           : aliased AWA.Mail.Modules.Mail_Module;

   Jobs           : aliased AWA.Jobs.Modules.Job_Module;

   Comments       : aliased AWA.Comments.Modules.Comment_Module;

   Blogs          : aliased AWA.Blogs.Modules.Blog_Module;

   Storages       : aliased AWA.Storages.Modules.Storage_Module;

   Images         : aliased AWA.Images.Modules.Image_Module;

   Questions      : aliased AWA.Questions.Modules.Question_Module;

   Votes          : aliased AWA.Votes.Modules.Vote_Module;

   Tags           : aliased AWA.Tags.Modules.Tag_Module;

   Settings       : aliased AWA.Settings.Modules.Setting_Module;

   Changelogs     : aliased AWA.Changelogs.Modules.Changelog_Module;

   Wikis          : aliased AWA.Wikis.Modules.Wiki_Module;

   Counters       : aliased AWA.Counters.Modules.Counter_Module;

   Date_Converter : aliased ASF.Converters.Dates.Date_Converter;

   Rel_Date_Converter : aliased AWA.Converters.Dates.Relative_Date_Converter;

   Tests : aliased Util.Tests.Test_Suite;

   function Suite return Util.Tests.Access_Test_Suite is
      Ret : constant Util.Tests.Access_Test_Suite := Tests'Access;
   begin
      AWA.Modules.Tests.Add_Tests (Ret);
      AWA.Events.Services.Tests.Add_Tests (Ret);
      AWA.Mail.Clients.Tests.Add_Tests (Ret);
      AWA.Mail.Modules.Tests.Add_Tests (Ret);
      AWA.Users.Services.Tests.Add_Tests (Ret);
      AWA.Users.Tests.Add_Tests (Ret);
      AWA.Workspaces.Tests.Add_Tests (Ret);
      AWA.Counters.Modules.Tests.Add_Tests (Ret);
      AWA.Helpers.Selectors.Tests.Add_Tests (Ret);
      AWA.Jobs.Modules.Tests.Add_Tests (Ret);
      AWA.Jobs.Services.Tests.Add_Tests (Ret);
      AWA.Settings.Modules.Tests.Add_Tests (Ret);
      AWA.Comments.Modules.Tests.Add_Tests (Ret);
      AWA.Blogs.Modules.Tests.Add_Tests (Ret);
      AWA.Blogs.Tests.Add_Tests (Ret);
      AWA.Storages.Services.Tests.Add_Tests (Ret);
      AWA.Images.Services.Tests.Add_Tests (Ret);
      AWA.Changelogs.Modules.Tests.Add_Tests (Ret);
      AWA.Votes.Modules.Tests.Add_Tests (Ret);
      AWA.Tags.Modules.Tests.Add_Tests (Ret);
      AWA.Questions.Modules.Tests.Add_Tests (Ret);
      AWA.Wikis.Modules.Tests.Add_Tests (Ret);
      return Ret;
   end Suite;

   procedure Initialize (Props : in Util.Properties.Manager) is
   begin
      Initialize (null, Props, True);
   end Initialize;

   --  ------------------------------
   --  Initialize the AWA test framework mockup.
   --  ------------------------------
   procedure Initialize (App         : in AWA.Applications.Application_Access;
                         Props       : in Util.Properties.Manager;
                         Add_Modules : in Boolean) is
      use AWA.Applications;
   begin
      AWA.Tests.Initialize (App, Props, Add_Modules);

      if Add_Modules then
         declare
            Application : constant Applications.Application_Access := AWA.Tests.Get_Application;
            Ctx         : AWA.Services.Contexts.Service_Context;
            Users  : constant AWA.Users.Modules.User_Module_Access := AWA.Testsuite.Users'Access;
         begin
            Ctx.Set_Context (Application, null);
            Register (App    => Application.all'Access,
                      Name   => AWA.Users.Modules.NAME,
                      URI    => "user",
                      Module => Users.all'Access);

            Register (App    => Application.all'Access,
                      Name   => "mail",
                      URI    => "mail",
                      Module => Mail'Access);

            Register (App    => Application.all'Access,
                      Name   => "workspaces",
                      URI    => "workspaces",
                      Module => Workspaces'Access);

            Register (App    => Application.all'Access,
                      Name   => AWA.Counters.Modules.NAME,
                      URI    => "counters",
                      Module => Counters'Access);

            Register (App    => Application.all'Access,
                      Name   => AWA.Comments.Modules.NAME,
                      URI    => "comments",
                      Module => Comments'Access);

            Register (App    => Application.all'Access,
                      Name   => AWA.Storages.Modules.NAME,
                      URI    => "storages",
                      Module => Storages'Access);

            Register (App    => Application.all'Access,
                      Name   => AWA.Jobs.Modules.NAME,
                      URI    => "jobs",
                      Module => Jobs'Access);

            Register (App    => Application.all'Access,
                      Name   => AWA.Images.Modules.NAME,
                      URI    => "images",
                      Module => Images'Access);

            Register (App    => Application.all'Access,
                      Name   => AWA.Settings.Modules.NAME,
                      URI    => "settings",
                      Module => Settings'Access);

            Register (App    => Application.all'Access,
                      Name   => AWA.Votes.Modules.NAME,
                      URI    => "votes",
                      Module => Votes'Access);

            Register (App    => Application.all'Access,
                      Name   => AWA.Changelogs.Modules.NAME,
                      URI    => "changelogs",
                      Module => Changelogs'Access);

            Register (App    => Application.all'Access,
                      Name   => AWA.Tags.Modules.NAME,
                      URI    => "tags",
                      Module => Tags'Access);

            Register (App    => Application.all'Access,
                      Name   => AWA.Blogs.Modules.NAME,
                      URI    => "blogs",
                      Module => Blogs'Access);

            Register (App    => Application.all'Access,
                      Name   => AWA.Questions.Modules.NAME,
                      URI    => "questions",
                      Module => Questions'Access);

            Register (App    => Application.all'Access,
                      Name   => AWA.Wikis.Modules.NAME,
                      URI    => "wikis",
                      Module => Wikis'Access);

            Application.Add_Converter (Name      => "dateConverter",
                                       Converter => Date_Converter'Access);
            Application.Add_Converter (Name      => "smartDateConverter",
                                       Converter => Rel_Date_Converter'Access);
            Application.Start;
--              if Props.Exists ("test.server") then
--                 declare
--                    WS : ASF.Server.Web.AWS_Container;
--                 begin
--                    Application.Add_Converter (Name      => "dateConverter",
--                                               Converter => Date_Converter'Access);
--                    Application.Add_Converter (Name      => "smartDateConverter",
--                                               Converter => Rel_Date_Converter'Access);
--
--                    WS.Register_Application ("/asfunit", Application.all'Access);
--
--                    WS.Start;
--                    delay 6000.0;
--                 end;
--              end if;
            ASF.Server.Tests.Set_Context (Application.all'Access);
         end;
      end if;
   end Initialize;

end AWA.Testsuite;

Add the workspace unit tests

Add the workspace unit tests


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

with Ada.Strings.Unbounded;
with Ada.Characters.Conversions;

with ASF.Models.Selects;
with ASF.Components.Utils;
with ASF.Components.Html.Messages;
with ASF.Events.Faces.Actions;
with ASF.Applications.Messages.Vectors;

with Util.Beans.Basic;
with Util.Strings.Transforms;
package body ASF.Components.Widgets.Inputs is

   --  ------------------------------
   --  Render the input field title.
   --  ------------------------------
   procedure Render_Title (UI      : in UIInput;
                           Name    : in String;
                           Writer  : in Response_Writer_Access;
                           Context : in out Faces_Context'Class) is
      Title : constant Util.Beans.Objects.Object := UI.Get_Attribute (Context, "title");
   begin
      Writer.Start_Element ("dt");
      Writer.Start_Element ("label");
      Writer.Write_Attribute ("for", Name);
      Writer.Write_Text (Title);
      Writer.End_Element ("label");
      Writer.End_Element ("dt");
   end Render_Title;

   --  ------------------------------
   --  Render the input component.  Starts the DL/DD list and write the input
   --  component with the possible associated error message.
   --  ------------------------------
   overriding
   procedure Encode_Begin (UI      : in UIInput;
                           Context : in out Faces_Context'Class) is
   begin
      if not UI.Is_Rendered (Context) then
         return;
      end if;
      declare
         Id       : constant String := To_String (UI.Get_Client_Id);
         Writer   : constant Response_Writer_Access := Context.Get_Response_Writer;
         Messages : constant ASF.Applications.Messages.Vectors.Cursor := Context.Get_Messages (Id);
         Style    : constant String := UI.Get_Attribute ("styleClass", Context);
      begin
         Writer.Start_Element ("dl");
         Writer.Write_Attribute ("id", Id);
         if ASF.Applications.Messages.Vectors.Has_Element (Messages) then
            Writer.Write_Attribute ("class", Style & " asf-error");
         elsif Style'Length > 0 then
            Writer.Write_Attribute ("class", Style);
         end if;
         UI.Render_Title (Id, Writer, Context);
         Writer.Start_Element ("dd");
         UI.Render_Input (Context, Write_Id => False);
      end;
   end Encode_Begin;

   --  ------------------------------
   --  Render the end of the input component.  Closes the DL/DD list.
   --  ------------------------------
   overriding
   procedure Encode_End (UI      : in UIInput;
                         Context : in out Faces_Context'Class) is
      use ASF.Components.Html.Messages;
   begin
      if not UI.Is_Rendered (Context) then
         return;
      end if;

      --  Render the error message associated with the input field.
      declare
         Id       : constant String := To_String (UI.Get_Client_Id);
         Writer   : constant Response_Writer_Access := Context.Get_Response_Writer;
         Messages : constant ASF.Applications.Messages.Vectors.Cursor := Context.Get_Messages (Id);
      begin
         if ASF.Applications.Messages.Vectors.Has_Element (Messages) then
            Write_Message (UI, ASF.Applications.Messages.Vectors.Element (Messages),
                           SPAN_NO_STYLE, False, True, Context);
         end if;
         Writer.End_Element ("dd");
         Writer.End_Element ("dl");
      end;
   end Encode_End;

   --  ------------------------------
   --  Render the end of the input component.  Closes the DL/DD list.
   --  ------------------------------
   overriding
   procedure Encode_End (UI      : in UIComplete;
                         Context : in out Faces_Context'Class) is
   begin
      if not UI.Is_Rendered (Context) then
         return;
      end if;

      --  Render the autocomplete script and finish the input component.
      declare
         Id       : constant String := To_String (UI.Get_Client_Id);
         Writer   : constant Response_Writer_Access := Context.Get_Response_Writer;
      begin
         Writer.Queue_Script ("$('#");
         Writer.Queue_Script (Id);
         Writer.Queue_Script (" input').complete({");
         Writer.Queue_Script ("});");
         UIInput (UI).Encode_End (Context);
      end;
   end Encode_End;

   overriding
   procedure Process_Decodes (UI      : in out UIComplete;
                              Context : in out Faces_Context'Class) is
   begin
      if not UI.Is_Rendered (Context) then
         return;
      end if;
      declare
         Id  : constant String := To_String (UI.Get_Client_Id);
         Val : constant String := Context.Get_Parameter (Id & ".match");
      begin
         if Val'Length > 0 then
            UI.Match_Value := Util.Beans.Objects.To_Object (Val);
         else
            ASF.Components.Html.Forms.UIInput (UI).Process_Decodes (Context);
         end if;
      end;
   end Process_Decodes;

   procedure Render_List (UI      : in UIComplete;
                          Match   : in String;
                          Context : in out Faces_Context'Class) is
      use type Util.Beans.Basic.List_Bean_Access;

      procedure Render_Item (Label : in String);

      List       : constant Util.Beans.Basic.List_Bean_Access
        := ASF.Components.Utils.Get_List_Bean (UI, "autocompleteList", Context);
      Writer     : constant Response_Writer_Access := Context.Get_Response_Writer;
      Need_Comma : Boolean := False;
      Count      : Natural;

      procedure Render_Item (Label : in String) is
         Result : Ada.Strings.Unbounded.Unbounded_String;
      begin
         if Match'Length = 0 or else
           (Match'Length <= Label'Length
            and then Match = Label (Label'First .. Label'First + Match'Length - 1)) then
            if Need_Comma then
               Writer.Write (",");
            end if;
            Writer.Write ('"');
            Util.Strings.Transforms.Escape_Java (Content => Label,
                                                 Into    => Result);
            Writer.Write (Result);
            Writer.Write ('"');
            Need_Comma := True;
         end if;
      end Render_Item;

   begin
      Writer.Write ('[');
      if List /= null then
         Count := List.Get_Count;
         if List.all in ASF.Models.Selects.Select_Item_List'Class then
            declare
               S : constant access ASF.Models.Selects.Select_Item_List'Class
                 := ASF.Models.Selects.Select_Item_List'Class (List.all)'Access;
            begin
               for I in 1 .. Count loop
                  Render_Item (Ada.Characters.Conversions.To_String (S.Get_Select_Item (I).Get_Label));
               end loop;
            end;
         else
            for I in 1 .. Count loop
               List.Set_Row_Index (I);
               declare
                  Value : constant Util.Beans.Objects.Object := List.Get_Row;
                  Label : constant String := Util.Beans.Objects.To_String (Value);
               begin
                  Render_Item (Label);
               end;
            end loop;
         end if;
      end if;
      Writer.Write (']');
   end Render_List;

   overriding
   procedure Process_Updates (UI      : in out UIComplete;
                              Context : in out Faces_Context'Class) is
   begin
      if not Util.Beans.Objects.Is_Empty (UI.Match_Value) then
         declare
            Value : constant access ASF.Views.Nodes.Tag_Attribute := UI.Get_Attribute ("match");
            ME    : EL.Expressions.Method_Expression;
         begin
            if Value /= null then
               declare
                  VE    : constant EL.Expressions.Value_Expression
                    := ASF.Views.Nodes.Get_Value_Expression (Value.all);
               begin
                  VE.Set_Value (Value => UI.Match_Value, Context => Context.Get_ELContext.all);
               end;
            end if;

            --  Post an event on this component to trigger the rendering of the completion
            --  list as part of an application/json output.  The rendering is made by Broadcast.
            ASF.Events.Faces.Actions.Post_Event (UI     => UI,
                                                 Method => ME);
         end;
      else
         ASF.Components.Html.Forms.UIInput (UI).Process_Updates (Context);
      end if;

--     exception
--        when E : others =>
--           UI.Is_Valid := False;
--           UI.Add_Message (CONVERTER_MESSAGE_NAME, "convert", Context);
--           Log.Info (Utils.Get_Line_Info (UI)
--                     & ": Exception raised when updating value {0} for component {1}: {2}",
--                     EL.Objects.To_String (UI.Submitted_Value),
--                     To_String (UI.Get_Client_Id), Ada.Exceptions.Exception_Name (E));
   end Process_Updates;

   --  ------------------------------
   --  Broadcast the event to the event listeners installed on this component.
   --  Listeners are called in the order in which they were added.
   --  ------------------------------
   overriding
   procedure Broadcast (UI      : in out UIComplete;
                        Event   : not null access ASF.Events.Faces.Faces_Event'Class;
                        Context : in out Faces_Context'Class) is
      pragma Unreferenced (Event);

      Match  : constant String := Util.Beans.Objects.To_String (UI.Match_Value);
   begin
      Context.Get_Response.Set_Content_Type ("application/json; charset=UTF-8");
      UI.Render_List (Match, Context);
      Context.Response_Completed;
   end Broadcast;

   --  ------------------------------
   --  Render the end of the input date component.
   --  Generate the javascript code to activate the input date selector
   --  and closes the DL/DD list.
   --  ------------------------------
   overriding
   procedure Encode_End (UI      : in UIInputDate;
                         Context : in out Faces_Context'Class) is
      use ASF.Components.Html.Messages;
   begin
      if not UI.Is_Rendered (Context) then
         return;
      end if;

      --  Render the input date script and finish the input component.
      declare
         Id       : constant String := To_String (UI.Get_Client_Id);
         Writer   : constant Response_Writer_Access := Context.Get_Response_Writer;
         Format   : constant String := UI.Get_Attribute ("dateFormat", Context);
      begin
         Writer.Queue_Script ("$('#");
         Writer.Queue_Script (Id);
         Writer.Queue_Script (" input').datepicker({");
         if Format'Length > 0 then
            Writer.Queue_Script ("dateFormat: """);
            Writer.Queue_Script (Format);
            Writer.Queue_Script ("""");
         end if;
         Writer.Queue_Script ("});");
         UIInput (UI).Encode_End (Context);
      end;
   end Encode_End;

end ASF.Components.Widgets.Inputs;

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

with Ada.Strings.Unbounded;
with Ada.Characters.Conversions;

with ASF.Models.Selects;
with ASF.Components.Utils;
with ASF.Components.Html.Messages;
with ASF.Events.Faces.Actions;
with ASF.Applications.Messages.Vectors;

with Util.Beans.Basic;
with Util.Strings.Transforms;
package body ASF.Components.Widgets.Inputs is

   --  ------------------------------
   --  Render the input field title.
   --  ------------------------------
   procedure Render_Title (UI      : in UIInput;
                           Name    : in String;
                           Writer  : in Response_Writer_Access;
                           Context : in out Faces_Context'Class) is
      Title : constant Util.Beans.Objects.Object := UI.Get_Attribute (Context, "title");
   begin
      Writer.Start_Element ("dt");
      Writer.Start_Element ("label");
      Writer.Write_Attribute ("for", Name);
      Writer.Write_Text (Title);
      Writer.End_Element ("label");
      Writer.End_Element ("dt");
   end Render_Title;

   --  ------------------------------
   --  Render the input component.  Starts the DL/DD list and write the input
   --  component with the possible associated error message.
   --  ------------------------------
   overriding
   procedure Encode_Begin (UI      : in UIInput;
                           Context : in out Faces_Context'Class) is
   begin
      if not UI.Is_Rendered (Context) then
         return;
      end if;
      declare
         Id       : constant String := To_String (UI.Get_Client_Id);
         Writer   : constant Response_Writer_Access := Context.Get_Response_Writer;
         Messages : constant ASF.Applications.Messages.Vectors.Cursor := Context.Get_Messages (Id);
         Style    : constant String := UI.Get_Attribute ("styleClass", Context);
      begin
         Writer.Start_Element ("dl");
         Writer.Write_Attribute ("id", Id);
         if ASF.Applications.Messages.Vectors.Has_Element (Messages) then
            Writer.Write_Attribute ("class", Style & " asf-error");
         elsif Style'Length > 0 then
            Writer.Write_Attribute ("class", Style);
         end if;
         UI.Render_Title (Id, Writer, Context);
         Writer.Start_Element ("dd");
         UI.Render_Input (Context, Write_Id => False);
      end;
   end Encode_Begin;

   --  ------------------------------
   --  Render the end of the input component.  Closes the DL/DD list.
   --  ------------------------------
   overriding
   procedure Encode_End (UI      : in UIInput;
                         Context : in out Faces_Context'Class) is
      use ASF.Components.Html.Messages;
   begin
      if not UI.Is_Rendered (Context) then
         return;
      end if;

      --  Render the error message associated with the input field.
      declare
         Id       : constant String := To_String (UI.Get_Client_Id);
         Writer   : constant Response_Writer_Access := Context.Get_Response_Writer;
         Messages : constant ASF.Applications.Messages.Vectors.Cursor := Context.Get_Messages (Id);
      begin
         if ASF.Applications.Messages.Vectors.Has_Element (Messages) then
            Write_Message (UI, ASF.Applications.Messages.Vectors.Element (Messages),
                           SPAN_NO_STYLE, False, True, Context);
         end if;
         Writer.End_Element ("dd");
         Writer.End_Element ("dl");
      end;
   end Encode_End;

   --  ------------------------------
   --  Render the end of the input component.  Closes the DL/DD list.
   --  ------------------------------
   overriding
   procedure Encode_End (UI      : in UIComplete;
                         Context : in out Faces_Context'Class) is
   begin
      if not UI.Is_Rendered (Context) then
         return;
      end if;

      --  Render the autocomplete script and finish the input component.
      declare
         Id       : constant String := To_String (UI.Get_Client_Id);
         Writer   : constant Response_Writer_Access := Context.Get_Response_Writer;
      begin
         Writer.Queue_Script ("$('#");
         Writer.Queue_Script (Id);
         Writer.Queue_Script (" input').complete({");
         Writer.Queue_Script ("});");
         UIInput (UI).Encode_End (Context);
      end;
   end Encode_End;

   overriding
   procedure Process_Decodes (UI      : in out UIComplete;
                              Context : in out Faces_Context'Class) is
   begin
      if not UI.Is_Rendered (Context) then
         return;
      end if;
      declare
         Id  : constant String := To_String (UI.Get_Client_Id);
         Val : constant String := Context.Get_Parameter (Id & ".match");
      begin
         if Val'Length > 0 then
            UI.Match_Value := Util.Beans.Objects.To_Object (Val);
         else
            ASF.Components.Html.Forms.UIInput (UI).Process_Decodes (Context);
         end if;
      end;
   end Process_Decodes;

   procedure Render_List (UI      : in UIComplete;
                          Match   : in String;
                          Context : in out Faces_Context'Class) is
      use type Util.Beans.Basic.List_Bean_Access;

      procedure Render_Item (Label : in String);

      List       : constant Util.Beans.Basic.List_Bean_Access
        := ASF.Components.Utils.Get_List_Bean (UI, "autocompleteList", Context);
      Writer     : constant Response_Writer_Access := Context.Get_Response_Writer;
      Need_Comma : Boolean := False;
      Count      : Natural;

      procedure Render_Item (Label : in String) is
         Result : Ada.Strings.Unbounded.Unbounded_String;
      begin
         if Match'Length = 0 or else
           (Match'Length <= Label'Length
            and then Match = Label (Label'First .. Label'First + Match'Length - 1)) then
            if Need_Comma then
               Writer.Write (",");
            end if;
            Writer.Write ('"');
            Util.Strings.Transforms.Escape_Java (Content => Label,
                                                 Into    => Result);
            Writer.Write (Result);
            Writer.Write ('"');
            Need_Comma := True;
         end if;
      end Render_Item;

   begin
      Writer.Write ('[');
      if List /= null then
         Count := List.Get_Count;
         if List.all in ASF.Models.Selects.Select_Item_List'Class then
            declare
               S : constant access ASF.Models.Selects.Select_Item_List'Class
                 := ASF.Models.Selects.Select_Item_List'Class (List.all)'Access;
            begin
               for I in 1 .. Count loop
                  declare
                     Value : constant ASF.Models.Selects.Select_Item := S.Get_Select_Item (I);
                  begin
                     Render_Item (Ada.Characters.Conversions.To_String (Value.Get_Label));
                  end;
               end loop;
            end;
         else
            for I in 1 .. Count loop
               List.Set_Row_Index (I);
               declare
                  Value : constant Util.Beans.Objects.Object := List.Get_Row;
                  Label : constant String := Util.Beans.Objects.To_String (Value);
               begin
                  Render_Item (Label);
               end;
            end loop;
         end if;
      end if;
      Writer.Write (']');
   end Render_List;

   overriding
   procedure Process_Updates (UI      : in out UIComplete;
                              Context : in out Faces_Context'Class) is
   begin
      if not Util.Beans.Objects.Is_Empty (UI.Match_Value) then
         declare
            Value : constant access ASF.Views.Nodes.Tag_Attribute := UI.Get_Attribute ("match");
            ME    : EL.Expressions.Method_Expression;
         begin
            if Value /= null then
               declare
                  VE    : constant EL.Expressions.Value_Expression
                    := ASF.Views.Nodes.Get_Value_Expression (Value.all);
               begin
                  VE.Set_Value (Value => UI.Match_Value, Context => Context.Get_ELContext.all);
               end;
            end if;

            --  Post an event on this component to trigger the rendering of the completion
            --  list as part of an application/json output.  The rendering is made by Broadcast.
            ASF.Events.Faces.Actions.Post_Event (UI     => UI,
                                                 Method => ME);
         end;
      else
         ASF.Components.Html.Forms.UIInput (UI).Process_Updates (Context);
      end if;

--     exception
--        when E : others =>
--           UI.Is_Valid := False;
--           UI.Add_Message (CONVERTER_MESSAGE_NAME, "convert", Context);
--           Log.Info (Utils.Get_Line_Info (UI)
--                     & ": Exception raised when updating value {0} for component {1}: {2}",
--                     EL.Objects.To_String (UI.Submitted_Value),
--                     To_String (UI.Get_Client_Id), Ada.Exceptions.Exception_Name (E));
   end Process_Updates;

   --  ------------------------------
   --  Broadcast the event to the event listeners installed on this component.
   --  Listeners are called in the order in which they were added.
   --  ------------------------------
   overriding
   procedure Broadcast (UI      : in out UIComplete;
                        Event   : not null access ASF.Events.Faces.Faces_Event'Class;
                        Context : in out Faces_Context'Class) is
      pragma Unreferenced (Event);

      Match  : constant String := Util.Beans.Objects.To_String (UI.Match_Value);
   begin
      Context.Get_Response.Set_Content_Type ("application/json; charset=UTF-8");
      UI.Render_List (Match, Context);
      Context.Response_Completed;
   end Broadcast;

   --  ------------------------------
   --  Render the end of the input date component.
   --  Generate the javascript code to activate the input date selector
   --  and closes the DL/DD list.
   --  ------------------------------
   overriding
   procedure Encode_End (UI      : in UIInputDate;
                         Context : in out Faces_Context'Class) is
      use ASF.Components.Html.Messages;
   begin
      if not UI.Is_Rendered (Context) then
         return;
      end if;

      --  Render the input date script and finish the input component.
      declare
         Id       : constant String := To_String (UI.Get_Client_Id);
         Writer   : constant Response_Writer_Access := Context.Get_Response_Writer;
         Format   : constant String := UI.Get_Attribute ("dateFormat", Context);
      begin
         Writer.Queue_Script ("$('#");
         Writer.Queue_Script (Id);
         Writer.Queue_Script (" input').datepicker({");
         if Format'Length > 0 then
            Writer.Queue_Script ("dateFormat: """);
            Writer.Queue_Script (Format);
            Writer.Queue_Script ("""");
         end if;
         Writer.Queue_Script ("});");
         UIInput (UI).Encode_End (Context);
      end;
   end Encode_End;

end ASF.Components.Widgets.Inputs;

Fix compilation warning (line too long)

Fix compilation warning (line too long)


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

with MAT.Types;
with MAT.Events.Targets;
package MAT.Formats is

   --  Format the address into a string.
   function Addr (Value : in MAT.Types.Target_Addr) return String;

   --  Format the size into a string.
   function Size (Value : in MAT.Types.Target_Size) return String;

   --  Format the time relative to the start time.
   function Time (Value : in MAT.Types.Target_Tick_Ref;
                  Start : in MAT.Types.Target_Tick_Ref) return String;

   --  Format the duration in seconds, milliseconds or microseconds.
   function Duration (Value : in MAT.Types.Target_Tick_Ref) return String;

   --  Format a file, line, function information into a string.
   function Location (File : in Ada.Strings.Unbounded.Unbounded_String;
                      Line : in Natural;
                      Func : in Ada.Strings.Unbounded.Unbounded_String) return String;

   --  Format a short description of the event.
   function Event (Item    : in MAT.Events.Targets.Probe_Event_Type;
                   Related : in MAT.Events.Targets.Target_Event_Vector) return String;

end MAT.Formats;

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

with MAT.Types;
with MAT.Events.Targets;
package MAT.Formats is

   --  Format the address into a string.
   function Addr (Value : in MAT.Types.Target_Addr) return String;

   --  Format the size into a string.
   function Size (Value : in MAT.Types.Target_Size) return String;

   --  Format the time relative to the start time.
   function Time (Value : in MAT.Types.Target_Tick_Ref;
                  Start : in MAT.Types.Target_Tick_Ref) return String;

   --  Format the duration in seconds, milliseconds or microseconds.
   function Duration (Value : in MAT.Types.Target_Tick_Ref) return String;

   --  Format a file, line, function information into a string.
   function Location (File : in Ada.Strings.Unbounded.Unbounded_String;
                      Line : in Natural;
                      Func : in Ada.Strings.Unbounded.Unbounded_String) return String;

   --  Format a short description of the event.
   function Event (Item       : in MAT.Events.Targets.Probe_Event_Type;
                   Related    : in MAT.Events.Targets.Target_Event_Vector;
                   Start_Time : in MAT.Types.Target_Tick_Ref) return String;

end MAT.Formats;

Add a Start_Time to the Event function to print relative time


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

with System.Storage_Pools;

with GNAT.Debug_Pools;

with Natools.S_Expressions.Atom_Buffers;
with Natools.S_Expressions.Caches;
with Natools.S_Expressions.Generic_Caches;
with Natools.S_Expressions.Printers;
with Natools.S_Expressions.Test_Tools;

package body Natools.S_Expressions.Cache_Tests is

   Pool : GNAT.Debug_Pools.Debug_Pool;

   package Debug_Caches is new Generic_Caches
     (System.Storage_Pools.Root_Storage_Pool'Class (Pool),
      System.Storage_Pools.Root_Storage_Pool'Class (Pool),
      System.Storage_Pools.Root_Storage_Pool'Class (Pool));

   procedure Inject_Test (Printer : in out Printers.Printer'Class);
      --  Inject test S-expression into Pr

   function Canonical_Test return Atom;
      --  Return canonical encoding of test S-expression above

   ------------------------
   -- Helper Subprograms --
   ------------------------

   function Canonical_Test return Atom is
   begin
      return To_Atom ("5:begin(()(4:head4:tail))3:end");
   end Canonical_Test;

   procedure Inject_Test (Printer : in out Printers.Printer'Class) is
   begin
      Printer.Append_Atom (To_Atom ("begin"));
      Printer.Open_List;
      Printer.Open_List;
      Printer.Close_List;
      Printer.Open_List;
      Printer.Append_Atom (To_Atom ("head"));
      Printer.Append_Atom (To_Atom ("tail"));
      Printer.Close_List;
      Printer.Close_List;
      Printer.Append_Atom (To_Atom ("end"));
   end Inject_Test;

   -------------------------
   -- Complete Test Suite --
   -------------------------

   procedure All_Tests (Report : in out NT.Reporter'Class) is
   begin
      Default_Instantiation (Report);
      Debug_Instantiation (Report);
      Descriptor_Interface (Report);
   end All_Tests;

   -----------------------
   -- Inidividual Tests --
   -----------------------

   procedure Debug_Instantiation (Report : in out NT.Reporter'Class) is
      Test : NT.Test := Report.Item ("Debug instantiation");
      Buffer : Atom_Buffers.Atom_Buffer;

      procedure Put (S : in String);
      procedure Put_Line (S : in String);
      procedure Flush;
      procedure Info_Pool;

      procedure Put (S : in String) is
      begin
         Buffer.Append (To_Atom (S));
      end Put;

      procedure Put_Line (S : in String) is
      begin
         Test.Info (To_String (Buffer.Data) & S);
         Buffer.Soft_Reset;
      end Put_Line;

      procedure Flush is
      begin
         if Buffer.Length > 0 then
            Test.Info (To_String (Buffer.Data));
         end if;
         Buffer.Hard_Reset;
      end Flush;

      procedure Info_Pool is
         procedure Print_Info is new GNAT.Debug_Pools.Print_Info;
      begin
         Print_Info (Pool);
         Flush;
      end Info_Pool;
   begin
      declare
         Cache, Deep, Shallow : Debug_Caches.Reference;
      begin
         Inject_Test (Cache);

         declare
            First : Debug_Caches.Cursor := Cache.First;
            Output : aliased Test_Tools.Memory_Stream;
            Pr : Printers.Canonical (Output'Access);
         begin
            Output.Set_Expected (Canonical_Test);
            Printers.Transfer (First, Pr);
            Output.Check_Stream (Test);
         end;

         Deep := Cache.Duplicate;
         Shallow := Deep;
         Deep.Append_Atom (To_Atom ("more"));

         declare
            Other : Debug_Caches.Cursor := Deep.First;
            Output : aliased Test_Tools.Memory_Stream;
            Pr : Printers.Canonical (Output'Access);
         begin
            Output.Set_Expected (Canonical_Test & To_Atom ("4:more"));
            Printers.Transfer (Other, Pr);
            Output.Check_Stream (Test);
         end;

         declare
            Second : Debug_Caches.Cursor := Cache.First;
            Output : aliased Test_Tools.Memory_Stream;
            Pr : Printers.Canonical (Output'Access);
         begin
            Output.Set_Expected (Canonical_Test);
            Printers.Transfer (Second, Pr);
            Output.Check_Stream (Test);
         end;

         declare
            Second_Other : Debug_Caches.Cursor := Shallow.First;
            Output : aliased Test_Tools.Memory_Stream;
            Pr : Printers.Canonical (Output'Access);
         begin
            Output.Set_Expected (Canonical_Test & To_Atom ("4:more"));
            Printers.Transfer (Second_Other, Pr);
            Output.Check_Stream (Test);
         end;
      end;

      Info_Pool;
   exception
      when Error : others => Test.Report_Exception (Error);
   end Debug_Instantiation;

   procedure Default_Instantiation (Report : in out NT.Reporter'Class) is
      Test : NT.Test := Report.Item ("Default instantiation");
   begin
      declare
         Cache, Deep, Shallow : Caches.Reference;
      begin
         Inject_Test (Cache);

         declare
            First : Caches.Cursor := Cache.First;
            Output : aliased Test_Tools.Memory_Stream;
            Pr : Printers.Canonical (Output'Access);
         begin
            Output.Set_Expected (Canonical_Test);
            Printers.Transfer (First, Pr);
            Output.Check_Stream (Test);
         end;

         Deep := Cache.Duplicate;
         Shallow := Deep;
         Deep.Append_Atom (To_Atom ("more"));

         declare
            Other : Caches.Cursor := Deep.First;
            Output : aliased Test_Tools.Memory_Stream;
            Pr : Printers.Canonical (Output'Access);
         begin
            Output.Set_Expected (Canonical_Test & To_Atom ("4:more"));
            Printers.Transfer (Other, Pr);
            Output.Check_Stream (Test);
         end;

         declare
            Second : Caches.Cursor := Cache.First;
            Output : aliased Test_Tools.Memory_Stream;
            Pr : Printers.Canonical (Output'Access);
         begin
            Output.Set_Expected (Canonical_Test);
            Printers.Transfer (Second, Pr);
            Output.Check_Stream (Test);
         end;

         declare
            Second_Other : Caches.Cursor := Shallow.First;
            Output : aliased Test_Tools.Memory_Stream;
            Pr : Printers.Canonical (Output'Access);
         begin
            Output.Set_Expected (Canonical_Test & To_Atom ("4:more"));
            Printers.Transfer (Second_Other, Pr);
            Output.Check_Stream (Test);
         end;
      end;
   exception
      when Error : others => Test.Report_Exception (Error);
   end Default_Instantiation;

   procedure Descriptor_Interface (Report : in out NT.Reporter'Class) is
      Test : NT.Test := Report.Item ("Descriptor insterface");
   begin
      declare
         Cache : Caches.Reference;
         First, Second : Caches.Cursor;
      begin
         Cache.Append_Atom (To_Atom ("begin"));
         Cache.Open_List;
         Cache.Append_Atom (To_Atom ("command"));
         Cache.Open_List;
         Cache.Append_Atom (To_Atom ("first"));
         Cache.Append_Atom (To_Atom ("second"));
         Cache.Close_List;
         Cache.Close_List;
         Cache.Append_Atom (To_Atom ("end"));

         First := Cache.First;
         Second := First;

         Test_Tools.Test_Atom_Accessors (Test, First, To_Atom ("begin"), 0);
         Test_Tools.Test_Atom_Accessors (Test, Second, To_Atom ("begin"), 0);

         Test_Tools.Next_And_Check (Test, First, Events.Open_List, 1);
         Test_Tools.Test_Atom_Accessor_Exceptions (Test, First);
         Test_Tools.Next_And_Check (Test, First, To_Atom ("command"), 1);
         Test_Tools.Next_And_Check (Test, First, Events.Open_List, 2);
         Test_Tools.Next_And_Check (Test, Second, Events.Open_List, 1);
         Test_Tools.Next_And_Check (Test, First, To_Atom ("first"), 2);
         Test_Tools.Next_And_Check (Test, Second, To_Atom ("command"), 1);
         Test_Tools.Next_And_Check (Test, First, To_Atom ("second"), 2);
         Test_Tools.Next_And_Check (Test, First, Events.Close_List, 1);
         Test_Tools.Next_And_Check (Test, Second, Events.Open_List, 2);
         Test_Tools.Next_And_Check (Test, Second, To_Atom ("first"), 2);
         Test_Tools.Next_And_Check (Test, Second, To_Atom ("second"), 2);
         Test_Tools.Next_And_Check (Test, First, Events.Close_List, 0);
         Test_Tools.Next_And_Check (Test, Second, Events.Close_List, 1);
         Test_Tools.Test_Atom_Accessor_Exceptions (Test, Second);
         Test_Tools.Next_And_Check (Test, Second, Events.Close_List, 0);
         Test_Tools.Next_And_Check (Test, Second, To_Atom ("end"), 0);
         Test_Tools.Next_And_Check (Test, First, To_Atom ("end"), 0);
         Test_Tools.Next_And_Check (Test, First, Events.End_Of_Input, 0);
         Test_Tools.Next_And_Check (Test, Second, Events.End_Of_Input, 0);
      end;
   exception
      when Error : others => Test.Report_Exception (Error);
   end Descriptor_Interface;

end Natools.S_Expressions.Cache_Tests;

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

with System.Storage_Pools;

with GNAT.Debug_Pools;

with Natools.S_Expressions.Atom_Buffers;
with Natools.S_Expressions.Caches;
with Natools.S_Expressions.Generic_Caches;
with Natools.S_Expressions.Printers;
with Natools.S_Expressions.Test_Tools;

package body Natools.S_Expressions.Cache_Tests is

   Pool : GNAT.Debug_Pools.Debug_Pool;

   package Debug_Caches is new Generic_Caches
     (System.Storage_Pools.Root_Storage_Pool'Class (Pool),
      System.Storage_Pools.Root_Storage_Pool'Class (Pool),
      System.Storage_Pools.Root_Storage_Pool'Class (Pool));

   procedure Inject_Test (Printer : in out Printers.Printer'Class);
      --  Inject test S-expression into Pr

   function Canonical_Test return Atom;
      --  Return canonical encoding of test S-expression above

   ------------------------
   -- Helper Subprograms --
   ------------------------

   function Canonical_Test return Atom is
   begin
      return To_Atom ("5:begin(()(4:head4:tail))3:end");
   end Canonical_Test;

   procedure Inject_Test (Printer : in out Printers.Printer'Class) is
   begin
      Printer.Append_Atom (To_Atom ("begin"));
      Printer.Open_List;
      Printer.Open_List;
      Printer.Close_List;
      Printer.Open_List;
      Printer.Append_Atom (To_Atom ("head"));
      Printer.Append_Atom (To_Atom ("tail"));
      Printer.Close_List;
      Printer.Close_List;
      Printer.Append_Atom (To_Atom ("end"));
   end Inject_Test;

   -------------------------
   -- Complete Test Suite --
   -------------------------

   procedure All_Tests (Report : in out NT.Reporter'Class) is
   begin
      Default_Instantiation (Report);
      Debug_Instantiation (Report);
      Descriptor_Interface (Report);
   end All_Tests;

   -----------------------
   -- Inidividual Tests --
   -----------------------

   procedure Debug_Instantiation (Report : in out NT.Reporter'Class) is
      Test : NT.Test := Report.Item ("Debug instantiation");
      Buffer : Atom_Buffers.Atom_Buffer;

      procedure Put (S : in String);
      procedure Put_Line (S : in String);
      procedure Flush;
      procedure Info_Pool;

      procedure Put (S : in String) is
      begin
         Buffer.Append (To_Atom (S));
      end Put;

      procedure Put_Line (S : in String) is
      begin
         Test.Info (To_String (Buffer.Data) & S);
         Buffer.Soft_Reset;
      end Put_Line;

      procedure Flush is
      begin
         if Buffer.Length > 0 then
            Test.Info (To_String (Buffer.Data));
         end if;
         Buffer.Hard_Reset;
      end Flush;

      procedure Info_Pool is
         procedure Print_Info is new GNAT.Debug_Pools.Print_Info;
      begin
         Print_Info (Pool);
         Flush;
      end Info_Pool;
   begin
      declare
         Cache, Deep, Shallow : Debug_Caches.Reference;
      begin
         declare
            Empty_Cursor : Debug_Caches.Cursor := Deep.First;
            Event : Events.Event;
         begin
            Event := Empty_Cursor.Current_Event;
            if Event /= Events.End_Of_Input then
               Test.Fail ("Unexpected Empty_Cursor.Current_Event "
                 & Events.Event'Image (Event)
                 & " (expected End_Of_Input)");
            end if;

            Test_Tools.Next_And_Check
              (Test, Empty_Cursor, Events.End_Of_Input, 0);
         end;

         Inject_Test (Cache);

         declare
            First : Debug_Caches.Cursor := Cache.First;
            Output : aliased Test_Tools.Memory_Stream;
            Pr : Printers.Canonical (Output'Access);
         begin
            Output.Set_Expected (Canonical_Test);
            Printers.Transfer (First, Pr);
            Output.Check_Stream (Test);
         end;

         Deep := Cache.Duplicate;
         Shallow := Deep;
         Deep.Append_Atom (To_Atom ("more"));

         declare
            Other : Debug_Caches.Cursor := Deep.First;
            Output : aliased Test_Tools.Memory_Stream;
            Pr : Printers.Canonical (Output'Access);
         begin
            Output.Set_Expected (Canonical_Test & To_Atom ("4:more"));
            Printers.Transfer (Other, Pr);
            Output.Check_Stream (Test);
         end;

         declare
            Second : Debug_Caches.Cursor := Cache.First;
            Output : aliased Test_Tools.Memory_Stream;
            Pr : Printers.Canonical (Output'Access);
         begin
            Output.Set_Expected (Canonical_Test);
            Printers.Transfer (Second, Pr);
            Output.Check_Stream (Test);
         end;

         declare
            Second_Other : Debug_Caches.Cursor := Shallow.First;
            Output : aliased Test_Tools.Memory_Stream;
            Pr : Printers.Canonical (Output'Access);
         begin
            Output.Set_Expected (Canonical_Test & To_Atom ("4:more"));
            Printers.Transfer (Second_Other, Pr);
            Output.Check_Stream (Test);
         end;
      end;

      Info_Pool;
   exception
      when Error : others => Test.Report_Exception (Error);
   end Debug_Instantiation;

   procedure Default_Instantiation (Report : in out NT.Reporter'Class) is
      Test : NT.Test := Report.Item ("Default instantiation");
   begin
      declare
         Cache, Deep, Shallow : Caches.Reference;
      begin
         declare
            Empty_Cursor : Caches.Cursor := Deep.First;
            Event : Events.Event;
         begin
            Event := Empty_Cursor.Current_Event;
            if Event /= Events.End_Of_Input then
               Test.Fail ("Unexpected Empty_Cursor.Current_Event "
                 & Events.Event'Image (Event)
                 & " (expected End_Of_Input)");
            end if;

            Test_Tools.Next_And_Check
              (Test, Empty_Cursor, Events.End_Of_Input, 0);
         end;
         Inject_Test (Cache);

         declare
            First : Caches.Cursor := Cache.First;
            Output : aliased Test_Tools.Memory_Stream;
            Pr : Printers.Canonical (Output'Access);
         begin
            Output.Set_Expected (Canonical_Test);
            Printers.Transfer (First, Pr);
            Output.Check_Stream (Test);
         end;

         Deep := Cache.Duplicate;
         Shallow := Deep;
         Deep.Append_Atom (To_Atom ("more"));

         declare
            Other : Caches.Cursor := Deep.First;
            Output : aliased Test_Tools.Memory_Stream;
            Pr : Printers.Canonical (Output'Access);
         begin
            Output.Set_Expected (Canonical_Test & To_Atom ("4:more"));
            Printers.Transfer (Other, Pr);
            Output.Check_Stream (Test);
         end;

         declare
            Second : Caches.Cursor := Cache.First;
            Output : aliased Test_Tools.Memory_Stream;
            Pr : Printers.Canonical (Output'Access);
         begin
            Output.Set_Expected (Canonical_Test);
            Printers.Transfer (Second, Pr);
            Output.Check_Stream (Test);
         end;

         declare
            Second_Other : Caches.Cursor := Shallow.First;
            Output : aliased Test_Tools.Memory_Stream;
            Pr : Printers.Canonical (Output'Access);
         begin
            Output.Set_Expected (Canonical_Test & To_Atom ("4:more"));
            Printers.Transfer (Second_Other, Pr);
            Output.Check_Stream (Test);
         end;
      end;
   exception
      when Error : others => Test.Report_Exception (Error);
   end Default_Instantiation;

   procedure Descriptor_Interface (Report : in out NT.Reporter'Class) is
      Test : NT.Test := Report.Item ("Descriptor insterface");
   begin
      declare
         Cache : Caches.Reference;
         First, Second : Caches.Cursor;
      begin
         Cache.Append_Atom (To_Atom ("begin"));
         Cache.Open_List;
         Cache.Append_Atom (To_Atom ("command"));
         Cache.Open_List;
         Cache.Append_Atom (To_Atom ("first"));
         Cache.Append_Atom (To_Atom ("second"));
         Cache.Close_List;
         Cache.Close_List;
         Cache.Append_Atom (To_Atom ("end"));

         First := Cache.First;
         Second := First;

         Test_Tools.Test_Atom_Accessors (Test, First, To_Atom ("begin"), 0);
         Test_Tools.Test_Atom_Accessors (Test, Second, To_Atom ("begin"), 0);

         Test_Tools.Next_And_Check (Test, First, Events.Open_List, 1);
         Test_Tools.Test_Atom_Accessor_Exceptions (Test, First);
         Test_Tools.Next_And_Check (Test, First, To_Atom ("command"), 1);
         Test_Tools.Next_And_Check (Test, First, Events.Open_List, 2);
         Test_Tools.Next_And_Check (Test, Second, Events.Open_List, 1);
         Test_Tools.Next_And_Check (Test, First, To_Atom ("first"), 2);
         Test_Tools.Next_And_Check (Test, Second, To_Atom ("command"), 1);
         Test_Tools.Next_And_Check (Test, First, To_Atom ("second"), 2);
         Test_Tools.Next_And_Check (Test, First, Events.Close_List, 1);
         Test_Tools.Next_And_Check (Test, Second, Events.Open_List, 2);
         Test_Tools.Next_And_Check (Test, Second, To_Atom ("first"), 2);
         Test_Tools.Next_And_Check (Test, Second, To_Atom ("second"), 2);
         Test_Tools.Next_And_Check (Test, First, Events.Close_List, 0);
         Test_Tools.Next_And_Check (Test, Second, Events.Close_List, 1);
         Test_Tools.Test_Atom_Accessor_Exceptions (Test, Second);
         Test_Tools.Next_And_Check (Test, Second, Events.Close_List, 0);
         Test_Tools.Next_And_Check (Test, Second, To_Atom ("end"), 0);
         Test_Tools.Next_And_Check (Test, First, To_Atom ("end"), 0);
         Test_Tools.Next_And_Check (Test, First, Events.End_Of_Input, 0);
         Test_Tools.Next_And_Check (Test, Second, Events.End_Of_Input, 0);
      end;
   exception
      when Error : others => Test.Report_Exception (Error);
   end Descriptor_Interface;

end Natools.S_Expressions.Cache_Tests;

s_expressions-cache_tests: add checks using empty reference and cursor