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

with Util.Test_Caller;

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

package body Util.Http.Clients.Tests is

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

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

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

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

   end Http_Tests;

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

   overriding
   procedure Tear_Down (T : in out Test) is
   begin
      if T.Server /= null then
         Log.Info ("Stopping test server");
         T.Server.Stop;
         T.Server := null;
      end if;
   end Tear_Down;

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

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

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

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

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

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

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

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

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

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

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

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

   end Test_Http_Post;

end Util.Http.Clients.Tests;

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

with Util.Test_Caller;

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

package body Util.Http.Clients.Tests is

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

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

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

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

   end Http_Tests;

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

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

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

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

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

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

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

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

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

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

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

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

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

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

   end Test_Http_Post;

end Util.Http.Clients.Tests;

Fix a memory leak in the unit test

Fix a memory leak in the unit test


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

package body Security.Controllers.URLs is

   --  ------------------------------
   --  Returns true if the user associated with the security context Context has
   --  the permission to access the URL defined in Permission.
   --  ------------------------------
   overriding
   function Has_Permission (Handler    : in URL_Controller;
                            Context    : in Security.Contexts.Security_Context'Class;
                            Permission : in Security.Permissions.Permission'Class)
                            return Boolean is
   begin
      if Permission in Security.Policies.URLs.URL_Permission'Class then
         return Handler.Manager.Has_Permission (Context,
                                                Policies.URLs.URL_Permission'Class (Permission));
      else
         return False;
      end if;
   end Has_Permission;

end Security.Controllers.URLs;

Implement the URL controller

Implement the URL controller


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

with Ada.Strings.Unbounded;
with Util.Http.Clients.AWS_I.Messages;
with Util.Http.Clients.AWS_I.Headers.Set;
with Util.Log.Loggers;
package body Util.Http.Clients.AWS is

   Log   : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Util.Http.Clients.Web");

   Manager : aliased AWS_Http_Manager;

   --  ------------------------------
   --  Register the Http manager.
   --  ------------------------------
   procedure Register is
   begin
      Default_Http_Manager := Manager'Access;
   end Register;

   function To_Status (Code : in AWS_I.Messages.Status_Code) return Natural;

   function To_Status (Code : in AWS_I.Messages.Status_Code) return Natural is
      use AWS_I.Messages;
   begin
      case Code is
         when S100 =>
            return 100;
         when S101 =>
            return 101;
         when S102 =>
            return 102;
         when S200 =>
            return 200;
         when S201 =>
            return 201;
         when S203 =>
            return 203;
         when S204 =>
            return 204;
         when S205 =>
            return 205;
         when S206 =>
            return 206;
         when S207 =>
            return 207;
         when S300 =>
            return 300;
         when S301 =>
            return 301;
         when S302 =>
            return 302;
         when S303 =>
            return 303;
         when S304 =>
            return 304;
         when S305 =>
            return 305;
         when S307 =>
            return 307;
         when S400 =>
            return 400;
         when S401 =>
            return 401;
         when S402 =>
            return 402;
         when S403 =>
            return 403;
         when S404 =>
            return 404;
         when S405 =>
            return 405;
         when S406 =>
            return 406;
         when S407 =>
            return 407;
         when S408 =>
            return 408;
         when S409 =>
            return 409;
         when S410 =>
            return 410;
         when S411 =>
            return 411;
         when S412 =>
            return 412;
         when S413 =>
            return 413;
         when S414 =>
            return 414;
         when S415 =>
            return 415;
         when S416 =>
            return 416;
         when S417 =>
            return 417;
         when S422 =>
            return 422;
         when S423 =>
            return 423;
         when S424 =>
            return 424;
         when S500 =>
            return 500;
         when S501 =>
            return 501;
         when S502 =>
            return 502;
         when S503 =>
            return 503;
         when S504 =>
            return 504;
         when S505 =>
            return 505;
         when S507 =>
            return 507;
         when others =>
            return 500;
      end case;
   end To_Status;

   procedure Create (Manager  : in AWS_Http_Manager;
                     Http     : in out Client'Class) is
      pragma Unreferenced (Manager);
   begin
      Http.Delegate := new AWS_Http_Request;
   end Create;

   overriding
   procedure Do_Get (Manager  : in AWS_Http_Manager;
                     Http     : in Client'Class;
                     URI      : in String;
                     Reply    : out Response'Class) is
      pragma Unreferenced (Manager);

      Req     : constant AWS_Http_Request_Access
        := AWS_Http_Request'Class (Http.Delegate.all)'Access;
      Rep     : constant AWS_Http_Response_Access := new AWS_Http_Response;
   begin
      Log.Info ("Get {0}", URI);

      Reply.Delegate := Rep.all'Access;
      Rep.Data       := AWS_I.Client.Get (URL => URI, Headers => Req.Headers,
                                        Timeouts => Req.Timeouts);
   end Do_Get;

   overriding
   procedure Do_Post (Manager  : in AWS_Http_Manager;
                      Http     : in Client'Class;
                      URI      : in String;
                      Data     : in String;
                      Reply    : out Response'Class) is
      pragma Unreferenced (Manager);

      Req     : constant AWS_Http_Request_Access
        := AWS_Http_Request'Class (Http.Delegate.all)'Access;
      Rep     : constant AWS_Http_Response_Access := new AWS_Http_Response;
   begin
      Log.Info ("Post {0}", URI);

      Reply.Delegate := Rep.all'Access;
      Rep.Data       := AWS_I.Client.Post (URL => URI, Data => Data,
                                         Headers => Req.Headers,
                                         Timeouts => Req.Timeouts);
   end Do_Post;

   overriding
   procedure Do_Put (Manager  : in AWS_Http_Manager;
                     Http     : in Client'Class;
                     URI      : in String;
                     Data     : in String;
                     Reply    : out Response'Class) is
      pragma Unreferenced (Manager);

      Req     : constant AWS_Http_Request_Access
        := AWS_Http_Request'Class (Http.Delegate.all)'Access;
      Rep     : constant AWS_Http_Response_Access := new AWS_Http_Response;
   begin
      Log.Info ("Put {0}", URI);

      Reply.Delegate := Rep.all'Access;
      Rep.Data       := AWS_I.Client.Put (URL => URI, Data => Data, Headers => Req.Headers,
                                        Timeouts => Req.Timeouts);
   end Do_Put;

   overriding
   procedure Do_Delete (Manager  : in AWS_Http_Manager;
                        Http     : in Client'Class;
                        URI      : in String;
                        Reply    : out Response'Class) is
      pragma Unreferenced (Manager, Http, Reply);
   begin
      Log.Info ("Delete {0}", URI);

      raise Program_Error with "Delete is not supported by AWS and there is no easy conditional"
        & " compilation in Ada to enable Delete support for the latest AWS version. "
        & "For now, you have to use curl, or install the latest AWS version and then "
        & "uncomment the AWS.Client.Delete call and remove this exception.";
   end Do_Delete;

   --  ------------------------------
   --  Set the timeout for the connection.
   --  ------------------------------
   overriding
   procedure Set_Timeout (Manager : in AWS_Http_Manager;
                          Http    : in Client'Class;
                          Timeout : in Duration) is
      pragma Unreferenced (Manager);
   begin
      AWS_Http_Request'Class (Http.Delegate.all).Timeouts
         := AWS_I.Client.Timeouts (Connect  => Timeout,
                                 Send     => Timeout,
                                 Receive  => Timeout,
                                 Response => Timeout);
   end Set_Timeout;

   --  ------------------------------
   --  Returns a boolean indicating whether the named request header has already
   --  been set.
   --  ------------------------------
   function Contains_Header (Http : in AWS_Http_Request;
                             Name : in String) return Boolean is
      Values : constant AWS_I.Headers.VString_Array
        := AWS_I.Headers.Get_Values (Http.Headers, Name);
   begin
      return Values'Length > 0;
   end Contains_Header;

   --  ------------------------------
   --  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 response header.
   --  ------------------------------
   overriding
   function Get_Header (Request : in AWS_Http_Request;
                        Name    : in String) return String is
      Values : constant AWS_I.Headers.VString_Array
        := AWS_I.Headers.Get_Values (Request.Headers, Name);
   begin
      if Values'Length > 0 then
         return Ada.Strings.Unbounded.To_String (Values (Values'First));
      else
         return "";
      end if;
   end Get_Header;

   --  ------------------------------
   --  Sets a request header with the given name and value. If the header had already
   --  been set, the new value overwrites the previous one. The containsHeader
   --  method can be used to test for the presence of a header before setting its value.
   --  ------------------------------
   overriding
   procedure Set_Header (Http  : in out AWS_Http_Request;
                         Name  : in String;
                         Value : in String) is
   begin
      AWS_I.Headers.Set.Add (Http.Headers, Name, Value);
   end Set_Header;

   --  ------------------------------
   --  Adds a request header with the given name and value.
   --  This method allows request headers to have multiple values.
   --  ------------------------------
   overriding
   procedure Add_Header (Http  : in out AWS_Http_Request;
                         Name  : in String;
                         Value : in String) is
   begin
      AWS_I.Headers.Set.Add (Http.Headers, Name, Value);
   end Add_Header;

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

   --  ------------------------------
   --  Returns a boolean indicating whether the named response header has already
   --  been set.
   --  ------------------------------
   function Contains_Header (Reply : in AWS_Http_Response;
                             Name  : in String) return Boolean is
   begin
      return AWS_I.Response.Header (Reply.Data, Name) /= "";
   end Contains_Header;

   --  ------------------------------
   --  Returns the value of the specified response header as a String. If the response
   --  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 response header.
   --  ------------------------------
   function Get_Header (Reply  : in AWS_Http_Response;
                        Name   : in String) return String is
   begin
      return AWS_I.Response.Header (Reply.Data, Name);
   end Get_Header;

   --  Sets a message header with the given name and value. If the header had already
   --  been set, the new value overwrites the previous one. The containsHeader
   --  method can be used to test for the presence of a header before setting its value.
   overriding
   procedure Set_Header (Reply    : in out AWS_Http_Response;
                         Name     : in String;
                         Value    : in String) is
   begin
      null;
   end Set_Header;

   --  Adds a request header with the given name and value.
   --  This method allows request headers to have multiple values.
   overriding
   procedure Add_Header (Reply   : in out AWS_Http_Response;
                         Name    : in String;
                         Value   : in String) is
   begin
      null;
   end Add_Header;

   --  Iterate over the response headers and executes the Process procedure.
   overriding
   procedure Iterate_Headers (Reply   : in AWS_Http_Response;
                              Process : not null access
                                procedure (Name  : in String;
                                           Value : in String)) is
   begin
      null;
   end Iterate_Headers;

   --  ------------------------------
   --  Get the response body as a string.
   --  ------------------------------
   function Get_Body (Reply : in AWS_Http_Response) return String is
   begin
      return AWS_I.Response.Message_Body (Reply.Data);
   end Get_Body;

   --  Get the response status code.
   overriding
   function Get_Status (Reply : in AWS_Http_Response) return Natural is
   begin
      return To_Status (AWS_I.Response.Status_Code (Reply.Data));
   end Get_Status;

end Util.Http.Clients.AWS;

Add support for old AWS versions (Delete not available)


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

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

   use ADO.Drivers.Connections;

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test ADO.Drivers.Get_Config",
                       Test_Get_Config'Access);
      Caller.Add_Test (Suite, "Test ADO.Drivers.Get_Driver",
                       Test_Get_Driver'Access);
      Caller.Add_Test (Suite, "Test ADO.Drivers.Get_Driver_Index",
                       Test_Get_Driver_Index'Access);
      Caller.Add_Test (Suite, "Test ADO.Drivers.Get_Driver",
                       Test_Load_Invalid_Driver'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test the Get_Config operation.
   --  ------------------------------
   procedure Test_Get_Config (T : in out Test) is
   begin
      T.Assert (ADO.Drivers.Get_Config ("test.database")'Length > 0,
                "The Get_Config operation returned no value for the test database");
   end Test_Get_Config;

   --  ------------------------------
   --  Test the Get_Driver operation.
   --  ------------------------------
   procedure Test_Get_Driver (T : in out Test) is
      Mysql_Driver  : constant Driver_Access := ADO.Drivers.Connections.Get_Driver ("mysql");
      Sqlite_Driver : constant Driver_Access := ADO.Drivers.Connections.Get_Driver ("sqlite");
   begin
      T.Assert (Mysql_Driver /= null or Sqlite_Driver /= null,
                "No database driver was found!");
   end Test_Get_Driver;

   --  ------------------------------
   --  Test loading some invalid database driver.
   --  ------------------------------
   procedure Test_Load_Invalid_Driver (T : in out Test) is
      Invalid_Driver  : constant Driver_Access := ADO.Drivers.Connections.Get_Driver ("invalid");
   begin
      T.Assert (Invalid_Driver = null,
                "The Get_Driver operation must return null for invalid drivers");
   end Test_Load_Invalid_Driver;

   --  ------------------------------
   --  Test the Get_Driver_Index operation.
   --  ------------------------------
   procedure Test_Get_Driver_Index (T : in out Test) is
      Mysql_Driver  : constant Driver_Access := ADO.Drivers.Connections.Get_Driver ("mysql");
      Sqlite_Driver : constant Driver_Access := ADO.Drivers.Connections.Get_Driver ("sqlite");
   begin
      if Mysql_Driver /= null then
         T.Assert (Mysql_Driver.Get_Driver_Index > 0, "The driver index must be positive");
      end if;
      if Sqlite_Driver /= null then
         T.Assert (Sqlite_Driver.Get_Driver_Index > 0, "The driver index must be positive");
      end if;
      if Mysql_Driver /= null and Sqlite_Driver /= null then
         T.Assert (Mysql_Driver.Get_Driver_Index /= Sqlite_Driver.Get_Driver_Index,
                   "Two drivers must have different driver indexes");
      end if;
   end Test_Get_Driver_Index;

end ADO.Drivers.Tests;

Implement the new tests for database drivers support


------------------------------------------------------------------------------
--                                                                          --
--                   ASIS-for-GNAT INTERFACE COMPONENTS                     --
--                                                                          --
--                   A S I S . L I M I T E D _ V I E W S                    --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--            Copyright (C) 2010-2011, Free Software Foundation, Inc.       --
--                                                                          --
-- This specification  is  added to be used together with the Ada  Semantic --
-- Interface Specification Standard (ISO/IEC 15291) for use with GNAT.      --                        --
--                                                                          --
-- ASIS-for-GNAT is free software; you can redistribute it and/or modify it --
-- under terms of the  GNU General Public License  as published by the Free --
-- Software Foundation;  either version 2,  or  (at your option)  any later --
-- version. ASIS-for-GNAT is distributed  in the hope  that it will be use- --
-- ful, but WITHOUT ANY WARRANTY; without even the implied warranty of MER- --
-- CHANTABILITY or  FITNESS FOR A PARTICULAR  PURPOSE.  See the GNU General --
-- Public License for more details.  You should have received a copy of the --
-- GNU  General  Public  License  distributed with ASIS-for-GNAT;  see file --
-- COPYING.  If not,  write  to the  Free Software Foundation,  51 Franklin --
-- Street, Fifth Floor, Boston, MA 02110-1301, USA.                         --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
-- ASIS-for-GNAT was originally developed  by the ASIS-for-GNAT team at the --
-- Software  Engineering  Laboratory  of  the Swiss  Federal  Institute  of --
-- Technology (LGL-EPFL) in Lausanne,  Switzerland, in cooperation with the --
-- Scientific  Research  Computer  Center of  Moscow State University (SRCC --
-- MSU), Russia,  with funding partially provided  by grants from the Swiss --
-- National  Science  Foundation  and  the  Swiss  Academy  of  Engineering --
-- Sciences.  ASIS-for-GNAT is now maintained by  AdaCore                   --
-- (http://www.adacore.com).                                                --
--                                                                          --
------------------------------------------------------------------------------

with Asis.Compilation_Units;    use Asis.Compilation_Units;
with Asis.Elements;             use Asis.Elements;
with Asis.Errors;               use Asis.Errors;
with Asis.Exceptions;           use Asis.Exceptions;

with Asis.Set_Get;              use  Asis.Set_Get;

with A4G.Asis_Tables;
with A4G.Contt.TT;
with A4G.Contt.UT;
with A4G.Mapping;               use A4G.Mapping;
with A4G.Vcheck;                use A4G.Vcheck;

with Atree;                     use Atree;
with Nlists;                    use Nlists;
with Sinfo;                     use Sinfo;

package body Asis.Limited_Views is

   Package_Name : constant String := "Asis.Limited_Views.";

   -------------------------
   -- Get_Nonlimited_View --
   -------------------------

   function Get_Nonlimited_View (D : Asis.Element) return Asis.Element is
      Encl_Unit     :          Asis.Compilation_Unit;
      Arg_Node      :          Node_Id;
      Res_Node      :          Node_Id;
      Def_Name_Case : constant Boolean := Element_Kind (D) = A_Defining_Name;
   begin
      if not Is_From_Limited_View (D) then
         Raise_ASIS_Inappropriate_Element
           (Package_Name &
            "Is_From_Limited_View (non-limited view as actual)",
            Wrong_Kind => Int_Kind (D));
      end if;

      Encl_Unit := Enclosing_Compilation_Unit (D);

      if Has_Limited_View_Only (Encl_Unit) then
         return Nil_Element;
      end if;

      Arg_Node := Node (D);

      if Def_Name_Case then
         while not (Is_List_Member (Arg_Node)
             or else
               Nkind (Arg_Node) = N_Package_Declaration)
         loop
            Arg_Node := Parent (Arg_Node);
         end loop;

      end if;

      A4G.Asis_Tables.Create_Node_Trace (Arg_Node);
      A4G.Contt.TT.Reset_Tree_For_Unit (Encl_Unit);
      Res_Node := A4G.Contt.TT.Restore_Node_From_Trace (CU => Encl_Unit);

      if Def_Name_Case then
         if Nkind (Res_Node) = N_Package_Declaration then
            if Is_List_Member (Res_Node) then
               Res_Node := Defining_Unit_Name (Sinfo.Specification (Res_Node));
            else
               Res_Node := Defining_Identifier (Res_Node);
            end if;
         end if;
      end if;

      return Node_To_Element_New
               (Node    => Res_Node,
                In_Unit => Encl_Unit);

   exception
      when ASIS_Inappropriate_Element =>
         raise;
      when ASIS_Failed =>

         if Status_Indicator = Unhandled_Exception_Error then
            Add_Call_Information
              (Argument   => D,
               Outer_Call => Package_Name & "Get_Nonlimited_View");
         end if;

         raise;
      when Ex : others =>
         Report_ASIS_Bug
           (Query_Name    => Package_Name & "Get_Nonlimited_View",
            Ex            => Ex,
            Arg_Element   => D);
   end Get_Nonlimited_View;

   ---------------------------
   -- Has_Limited_View_Only --
   ---------------------------

   function Has_Limited_View_Only
     (Right : Asis.Compilation_Unit)
     return Boolean
   is
      Result : Boolean := False;
   begin
      if Unit_Kind (Right) = A_Package
        and then
         not Is_Standard (Right)
      then
         Result := A4G.Contt.UT.Has_Limited_View_Only
                     (Encl_Cont_Id (Right),
                      Get_Unit_Id (Right));
      end if;

      return Result;
   exception
      when ASIS_Failed =>

         if Status_Indicator = Unhandled_Exception_Error then
            Add_Call_Information
              (Outer_Call => Package_Name & "Has_Limited_View_Only");
         end if;

         raise;

      when Ex : others =>
         Report_ASIS_Bug
           (Query_Name => Package_Name & "Has_Limited_View_Only",
            Ex         => Ex,
            Arg_CU     => Right);
   end Has_Limited_View_Only;

   --------------------------
   -- Is_From_Limited_View --
   --------------------------

   function Is_From_Limited_View (D : Asis.Element) return Boolean is
   begin
      return Special_Case (D) = From_Limited_View;
   end Is_From_Limited_View;

end Asis.Limited_Views;

Add the ASIS file $i

Add the ASIS file $i


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

package body Util.Commands.Parsers.GNAT_Parser is

   function To_OS_Lib_Argument_List (Args : in Argument_List'Class)
                                     return GNAT.OS_Lib.Argument_List_Access;

   function To_OS_Lib_Argument_List (Args : in Argument_List'Class)
                                     return GNAT.OS_Lib.Argument_List_Access is
      Count   : constant Natural := Args.Get_Count;
      New_Arg : GNAT.OS_Lib.Argument_List (1 .. Count);
   begin
      for I in 1 .. Count loop
         New_Arg (I) := new String '(Args.Get_Argument (I));
      end loop;
      return new GNAT.OS_Lib.Argument_List '(New_Arg);
   end To_OS_Lib_Argument_List;

   procedure Execute (Config : in out Config_Type;
                      Args   : in Util.Commands.Argument_List'Class;
                      Process : access procedure (Cmd_Args : in Commands.Argument_List'Class)) is
      Parser   : GNAT.Command_Line.Opt_Parser;
      Cmd_Args : Dynamic_Argument_List;
      Params   : GNAT.OS_Lib.Argument_List_Access
        := To_OS_Lib_Argument_List (Args);
   begin
      GNAT.Command_Line.Initialize_Option_Scan (Parser, Params);
      GNAT.Command_Line.Getopt (Config => Config, Parser => Parser);
      loop
         declare
            S : constant String := GNAT.Command_Line.Get_Argument (Parser => Parser);
         begin
            exit when S'Length = 0;
            Cmd_Args.List.Append (S);
         end;
      end loop;
      Process (Cmd_Args);
      GNAT.OS_Lib.Free (Params);

   exception
      when others =>
         GNAT.OS_Lib.Free (Params);
         raise;
   end Execute;

end Util.Commands.Parsers.GNAT_Parser;

Implement the GNAT_Parser package to parse arguments using GNAT Getopt


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

with Util.Tests;
with Util.Test_Caller;
with Util.Encoders.SHA1;
with Util.Encoders.Base16;
with Babel.Files.Signatures;

package body Babel.Stores.Local.Tests is

   package Caller is new Util.Test_Caller (Test, "Stores.Local");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Babel.Streams.Read",
                       Test_Read_File'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test the Read_File and Write_File operations.
   --  ------------------------------
   procedure Test_Read_File (T : in out Test) is
      Buffers   : aliased Babel.Files.Buffers.Buffer_Pool;
      Local     : aliased Babel.Stores.Local.Local_Store_Type;
      Stream    : Babel.Streams.Refs.Stream_Ref;
      Sign      : Util.Encoders.SHA1.Hash_Array;
      Sign_Copy : Util.Encoders.SHA1.Hash_Array;
      Hex       : Util.Encoders.Base16.Encoder;
   begin
      Buffers.Create_Pool (Size  => 16 * 1024,
                           Count => 10_000);
      Local.Set_Buffers (Buffers'Unchecked_Access);
      Local.Set_Root_Directory (Util.Tests.Get_Path (""));
      Local.Read_File ("bin/babel_harness", Stream);
      Local.Write_File ("regtests/result/babel_harness.copy", Stream, 8#755#);
      Babel.Files.Signatures.Sha1 (Stream, Sign);
      Local.Read_File ("regtests/result/babel_harness.copy", Stream);
      Babel.Files.Signatures.Sha1 (Stream, Sign_Copy);
      declare
         S1 : constant String := Util.Encoders.Transform (Hex, Sign);
         S2 : constant String := Util.Encoders.Transform (Hex, Sign_Copy);
      begin
         Util.Tests.Assert_Equals (T, S1, S2, "SHA1 comparison");
      end;
   end Test_Read_File;

end Babel.Stores.Local.Tests;

Implement the Test_Read_File procedure

Implement the Test_Read_File procedure


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

with Regtests.Simple.Model;
with ADO.Queries.Loaders;
package body ADO.Datasets.Tests is

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

   package User_List_Query_File is
     new ADO.Queries.Loaders.File (Path => "regtests/files/user-list.xml",
                                   Sha1 => "");

   package User_List_Query is
     new ADO.Queries.Loaders.Query (Name => "user-list",
                                    File => User_List_Query_File.File'Access);

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test ADO.Datasets.List",
                       Test_List'Access);
   end Add_Tests;

   procedure Test_List (T : in out Test) is
      DB     : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      Query  : ADO.Queries.Context;
      Data   : ADO.Datasets.Dataset;
      Props         : constant Util.Properties.Manager := Util.Tests.Get_Properties;
   begin
      --  Configure the XML query loader.
      ADO.Queries.Loaders.Initialize (Props.Get ("ado.queries.paths", ".;db"),
                                      Props.Get ("ado.queries.load", "false") = "true");
      for I in 1 .. 100 loop
         declare
            User : Regtests.Simple.Model.User_Ref;
         begin
            User.Set_Name ("John " & Integer'Image (I));
            User.Set_Select_Name ("test-list");
            User.Set_Value (ADO.Identifier (I));
            User.Save (DB);
         end;
      end loop;
      DB.Commit;

      Query.Set_Query (User_List_Query.Query'Access);
      Query.Bind_Param ("filter", String '("test-list"));
      ADO.Datasets.List (Data, DB, Query);
      Util.Tests.Assert_Equals (T, 100, Data.Get_Count, "Invalid dataset size");
   end Test_List;

end ADO.Datasets.Tests;

Implement the unit test on datasets

Implement the unit test on datasets


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

with Util.Tests;

with ASF.Contexts.Faces.Tests;
package ASF.Converters.Tests is

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite);

   type Test is new ASF.Contexts.Faces.Tests.Test with null record;

   --  Test the date short converter.
   procedure Test_Date_Short_Converter (T : in out Test);

   --  Test the date medium converter.
   procedure Test_Date_Medium_Converter (T : in out Test);

   --  Test the date long converter.
   procedure Test_Date_Long_Converter (T : in out Test);

   --  Test the date full converter.
   procedure Test_Date_Full_Converter (T : in out Test);

   --  Test the time short converter.
   procedure Test_Time_Short_Converter (T : in out Test);

   --  Test the time short converter.
   procedure Test_Time_Medium_Converter (T : in out Test);

   --  Test the time long converter.
   procedure Test_Time_Long_Converter (T : in out Test);

end ASF.Converters.Tests;

Add a new set of unit tests for the date converter


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

with Cairo;
with Gtk.Drawing_Area;

with MAT.Events.Targets;
package MAT.Events.Gtkmat is

   type Event_Drawing_Type is record
      Drawing : Gtk.Drawing_Area.Gtk_Drawing_Area;
      List    : MAT.Events.Targets.Target_Event_Vector;
   end record;
   type Event_Drawing_Type_Access is access Event_Drawing_Type;

   procedure Create (Drawing : in out Event_Drawing_Type);

   procedure Draw (Onto : in Event_Drawing_Type;
                   Cr   : in Cairo.Cairo_Context);

end MAT.Events.Gtkmat;

Define the MAT.Events.Gtkmat package to display the events in some window


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

package body Wiki.Strings is

   --  Search for the first occurrence of the character in the builder and
   --  starting after the from index.  Returns the index of the first occurence or 0.
   function Index (Source : in BString;
                   Char   : in WChar;
                   From   : in Positive := 1) return Natural is
      function Find (Content : in WString) return Natural;

      function Find (Content : in WString) return Natural is
      begin
         for I in Content'Range loop
            if Content (I) = Char then
               return I;
            end if;
         end loop;
         return 0;
      end Find;

      function Find_Builder is
         new Wide_Wide_Builders.Find (Find);

   begin
      return Find_Builder (Source, From);
   end Index;

end Wiki.Strings;

Add the Index function

Add the Index function


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

with Util.Streams.Buffered;
with Util.Streams.Files;
with Util.Log.Loggers;
with MAT.Readers.Marshaller;
package body MAT.Readers.Files is

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("MAT.Readers.Files");

   BUFFER_SIZE  : constant Natural := 100 * 1024;
   MAX_MSG_SIZE : constant Ada.Streams.Stream_Element_Offset := 2048;

   --  Open the file.
   procedure Open (Reader : in out File_Reader_Type;
                   Path   : in String) is
   begin
      Log.Info ("Reading data stream {0}", Path);

      Reader.Stream.Initialize (Size   => BUFFER_SIZE,
                                Input  => Reader.File'Unchecked_Access,
                                Output => Reader.File'Unchecked_Access);
      Reader.File.Open (Mode => Ada.Streams.Stream_IO.In_File,
                        Name => Path);
   end Open;

   procedure Read_All (Reader : in out File_Reader_Type) is
      use Ada.Streams;
      use type MAT.Types.Uint8;

      Data    : aliased Ada.Streams.Stream_Element_Array (0 .. MAX_MSG_SIZE);
      Buffer  : aliased Buffer_Type;
      Msg     : Message;
      Last    : Ada.Streams.Stream_Element_Offset;
      Size    : MAT.Types.Uint16;
      Version : MAT.Types.Uint16;
      Format  : MAT.Types.Uint8;
   begin
      Msg.Buffer := Buffer'Unchecked_Access;
      Msg.Buffer.Start := Data (0)'Address;
      Msg.Buffer.Current := Msg.Buffer.Start;
      Msg.Buffer.Last := Data (MAX_MSG_SIZE)'Address;
      Msg.Buffer.Size := 3;
      Reader.Stream.Read (Data (0 .. 2), Last);
      Format := MAT.Readers.Marshaller.Get_Uint8 (Msg.Buffer);
      if Format = 0 then
         Msg.Buffer.Endian := LITTLE_ENDIAN;
         Log.Debug ("Data stream is little endian");
      else
         Msg.Buffer.Endian := BIG_ENDIAN;
         Log.Debug ("Data stream is big endian");
      end if;
      Msg.Size := Natural (MAT.Readers.Marshaller.Get_Uint16 (Msg.Buffer));
      if Msg.Size < 2 then
         Log.Error ("Invalid message size {0}", Natural'Image (Msg.Size));
      end if;
--        Msg.Size := Msg.Size - 2;
      Reader.Stream.Read (Data (0 .. Ada.Streams.Stream_Element_Offset (Msg.Size - 1)), Last);
      Msg.Buffer.Current := Msg.Buffer.Start;
      Msg.Buffer.Last    := Data (Last)'Address;
      Msg.Buffer.Size    := Natural (Msg.Size);
      Reader.Read_Headers (Msg);
      while not Reader.Stream.Is_Eof loop
         Reader.Stream.Read (Data (0 .. 1), Last);
         exit when Last /= 2;
         Msg.Buffer.Size := 2;
         Msg.Buffer.Current := Msg.Buffer.Start;
         Msg.Size := Natural (MAT.Readers.Marshaller.Get_Uint16 (Msg.Buffer));
         if Msg.Size < 2 then
            Log.Error ("Invalid message size {0}", Natural'Image (Msg.Size));
         end if;
--           Msg.Size := Msg.Size - 2;
         Reader.Stream.Read (Data (0 .. Ada.Streams.Stream_Element_Offset (Msg.Size - 1)), Last);
         Msg.Buffer.Current := Msg.Buffer.Start;
         Msg.Buffer.Last    := Data (Last)'Address;
         Msg.Buffer.Size := Natural (Msg.Size);
         Reader.Dispatch_Message (Msg);
      end loop;
   end Read_All;

end MAT.Readers.Files;

Implement reading the event data stream from a file


-----------------------------------------------------------------------
--  mat-frames-targets - Representation of stack frames
--  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.
-----------------------------------------------------------------------

package body MAT.Frames.Targets is

   --  ------------------------------
   --  Insert in the frame tree the new stack frame represented by <tt>Pc</tt>.
   --  If the frame is already known, the frame reference counter is incremented.
   --  The frame represented by <tt>Pc</tt> is returned in <tt>Result</tt>.
   --  ------------------------------
   procedure Insert (Frame  : in out Target_Frames;
                     Pc     : in Frame_Table;
                     Result : out Frame_Type) is
   begin
      Frame.Frames.Insert (Pc, Result);
   end Insert;

   protected body Frames_Type is

      --  ------------------------------
      --  Insert in the frame tree the new stack frame represented by <tt>Pc</tt>.
      --  If the frame is already known, the frame reference counter is incremented.
      --  The frame represented by <tt>Pc</tt> is returned in <tt>Result</tt>.
      --  ------------------------------
      procedure Insert (Pc     : in Frame_Table;
                        Result : out Frame_Type) is
      begin
         MAT.Frames.Insert (Root, Pc, Result);
      end Insert;

      --  ------------------------------
      --  Clear and destroy all the frame instances.
      --  ------------------------------
      procedure Clear is
      begin
         Destroy (Root);
      end Clear;

   end Frames_Type;

   --  ------------------------------
   --  Release all the stack frames.
   --  ------------------------------
   overriding
   procedure Finalize (Frames : in out Target_Frames) is
   begin
      Frames.Frames.Clear;
   end Finalize;

end MAT.Frames.Targets;

Implement the Frames_Types package to protect the frame creation in multi-threaded contexts


------------------------------------------------------------------------------
--                                                                          --
--                 ASIS-for-GNAT IMPLEMENTATION COMPONENTS                  --
--                                                                          --
--                            A 4 G . A _ O P T                             --
--                                                                          --
--                                 S p e c                                  --
--                                                                          --
--            Copyright (C) 1995-2012, Free Software Foundation, Inc.       --
--                                                                          --
-- ASIS-for-GNAT is free software; you can redistribute it and/or modify it --
-- under terms of the  GNU General Public License  as published by the Free --
-- Software Foundation;  either version 2,  or  (at your option)  any later --
-- version. ASIS-for-GNAT is distributed  in the hope  that it will be use- --
-- ful, but WITHOUT ANY WARRANTY; without even the implied warranty of MER- --
-- CHANTABILITY or  FITNESS FOR A PARTICULAR  PURPOSE.  See the GNU General --
-- Public License for more details.  You should have received a copy of the --
-- GNU  General  Public  License  distributed with ASIS-for-GNAT;  see file --
-- COPYING.  If not,  write  to the  Free Software Foundation,  51 Franklin --
-- Street, Fifth Floor, Boston, MA 02110-1301, USA.                         --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
-- ASIS-for-GNAT was originally developed  by the ASIS-for-GNAT team at the --
-- Software  Engineering  Laboratory  of  the Swiss  Federal  Institute  of --
-- Technology (LGL-EPFL) in Lausanne,  Switzerland, in cooperation with the --
-- Scientific  Research  Computer  Center of  Moscow State University (SRCC --
-- MSU), Russia,  with funding partially provided  by grants from the Swiss --
-- National  Science  Foundation  and  the  Swiss  Academy  of  Engineering --
-- Sciences. ASIS-for-GNAT is now maintained by AdaCore                     --
-- (http://www.adacore.com).                                                --
--                                                                          --
------------------------------------------------------------------------------

--  This package contains global switches set by the
--  Asis_Environment.Initialize routine from the Parameters siting and
--  referenced throughout the ASIS-for-GNAT
--
--  This package may be considered as an ASIS analog of the GNAT Opt
--  package

package A4G.A_Opt is

   Is_Initialized  : Boolean := False;
   --  flag indicating if the environment has already been initialized.

   Was_Initialized_At_Least_Once : Boolean := False;
   --  flag indicating if the environment was initialized at least
   --  once during the current launch of an ASIS application

   type ASIS_Warning_Mode_Type is (Suppress, Normal, Treat_As_Error);
   ASIS_Warning_Mode : ASIS_Warning_Mode_Type := Normal;
   --  Controls treatment of warning messages. If set to Suppress, warning
   --  messages are not generated at all. In Normal mode, they are generated
   --  but do not count as errors. In Treat_As_Error mode, a warning is
   --  treated as an error: ASIS_Failed is raised and the warning message is
   --  sent to an ASIS Diagnosis string.

   Strong_Version_Check : Boolean := True;
   --  Strong version check means that version strings read from the tree and
   --  stored in Gnatvsn are compared. Weak check means comparing ASIS version
   --  numbers. See BA23-002

   Generate_Bug_Box : Boolean := True;
   --  Flag indicating if the ASIS bug box should be generated into Stderr
   --  when an ASIS implementation bug is detected.

   Keep_Going : Boolean := False;
   --  Flag indicating if the exit to OS should NOT be generated in case if
   --  ASIS internal implementation error. Set ON by Initialize '-k' parameter.

   ASIS_2005_Mode_Internal : Boolean := True;
   --  If this switch is ON, ASIS detects as predefined units also units listed
   --  as predefined in the 2005 revision of the Ada Standard. Now this flag is
   --  always ON, and we do not have any parameter to tell ASIS that only
   --  Ada 95 predefined units should be classified as predefined Compilation
   --  Units in ASIS.

   procedure Process_Initialization_Parameters (Parameters : String);
   --  Processes a Parameters string passed to the
   --  Asis.Implementation.Initialize query: check parameters and makes the
   --  corresponding settings for ASIS global switches and flags.

   procedure Process_Finalization_Parameters (Parameters : String);
   --  Processes a Parameters string passed to the
   --  Asis.Implementation.Finalize query.

   procedure Set_Off;
   --  Sets Is_Initialized flag OFF and then sets all the global switches
   --  except Was_Initialized_At_Least_Once in the initial (default) position.
   --  Is to be called by Asis_Environment.Finalize

   --  the type declarations below should probably be moved into A_Types???

   type  Context_Mode is
   --  different ways to define an ASIS Context:
     (One_Tree,
      --  a Context is made up by only one tree file
      N_Trees,
      --  a Context is made up by N tree files
      Partition,
      --  a partition Context
      All_Trees);
      --  all the tree files in tree search path are considered as making up a
      --  given Context

   type Tree_Mode is
   --  how ASIS deals with tree files
     (On_The_Fly,
      --  trees are created on the fly, created trees are reused as long as a
      --  Context remains opened
      Pre_Created,
      --  only those trees which have been created before a Context is opened
      --  are used
      Mixed,
      --  mixed approach - if ASIS cannot find a needed tree, it tries to
      --  create it on the fly
      Incremental,
      --  Similar to Mixed, but these mode goes beyond the ASIS standard and
      --  allows to change the environment when the Context remains open:
      --  -  when the Context is opened, all the existing trees are processed;
      --  -  if ASIS can not find a needed tree, it tries to create it on the
      --     fly, and it refreshes the information in the Context unit table
      --     using the data from this newly created tree;
      --  -  any access to a unit or to an element checks that a tree to be
      --     accessed is consistent with the sources
      --  ???? This documentation definitely needs revising???
      GNSA
      --  Any tree is created on the fly by calling GNSA. It is not written
      --  in a tree file and then read back by ASIS, but it is left in the
      --  same data structures where it has been created, and after that ASIS
      --  works on the same data structures.
      );

   type Source_Mode is
   --  how ASIS takes into account source files when checking the consistency
     (All_Sources,
      --  sources of all the units from a given Context (except the predefined
      --  Standard package) should be around, and they should be the same as
      --  the sources from which tree files making up the Context were created
      Existing_Sources,
      --  If for a given unit from the Context the corresponding source file
      --  exists, it should be the same as those used to create tree files
      --  making up the Context
      No_Sources);
      --  Existing  source files are not taken into account when checking the
      --  consistency of tree files

end A4G.A_Opt;

Add the ASIS file $i

Add the ASIS file $i


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

with Util.Properties.Bundles;
with Util.Beans.Objects;
with Util.Log.Loggers;

with ASF.Applications.Main;
package body ASF.Converters.Numbers is

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("ASF.Converters.Numbers");

   Local_Set : constant Ada.Strings.Maps.Character_Set
     := Ada.Strings.Maps.To_Set ("$#V_");

   type Float_Number is delta 0.0000000001 digits 18;

   package Formatter is
     new Ada.Text_IO.Editing.Decimal_Output (Num => Float_Number);

   --  ------------------------------
   --  Get the locale that must be used to format the number.
   --  ------------------------------
   function Get_Locale (Convert   : in Number_Converter;
                        Context   : in ASF.Contexts.Faces.Faces_Context'Class)
                        return Util.Locales.Locale is
      use type Util.Locales.Locale;
   begin
      if Convert.Locale /= Util.Locales.NULL_LOCALE then
         return Convert.Locale;
      else
         return Context.Get_Locale;
      end if;
   end Get_Locale;

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

      Bundle  : ASF.Locales.Bundle;
   begin
      if Convert.Depend_On_Local then
         declare
            Locale : constant Util.Locales.Locale
              := Number_Converter'Class (Convert).Get_Locale (Context);
         begin
            ASF.Applications.Main.Load_Bundle (Context.Get_Application.all,
                                               Name   => "asf",
                                               Locale => Util.Locales.To_String (Locale),
                                               Bundle => Bundle);

         exception
            when E : Util.Properties.Bundles.NO_BUNDLE =>
               Log.Error ("Cannot localize numbers: {0}", Ada.Exceptions.Exception_Message (E));
         end;
      end if;

      --  Convert the value as a date here so that we can raise an Invalid_Conversion exception.
      declare
         Currency   : constant String
           := Number_Converter'Class (Convert).Get_Currency (Bundle);
         Separator  : constant Character
           := Number_Converter'Class (Convert).Get_Separator (Bundle);
         Radix_Mark : constant Character
           := Number_Converter'Class (Convert).Get_Radix_Mark (Bundle);
         Fill : constant Character
           := Number_Converter'Class (Convert).Get_Fill (Bundle);
         Val     : constant Float_Number
           := Float_Number (Util.Beans.Objects.To_Long_Long_Float (Value));
         Result  : constant String
           := Formatter.Image (Val, Convert.Picture, Currency, Fill, Separator, Radix_Mark);
      begin
         return Result;
      end;

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

   end To_String;

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

   --  ------------------------------
   --  Get the currency to be used from the resource bundle in the user's current locale.
   --  ------------------------------
   function Get_Currency (Converter : in Number_Converter;
                          Bundle    : in ASF.Locales.Bundle) return String is
      pragma Unreferenced (Converter);
   begin
      return Bundle.Get ("faces.numbers.currency", "€");
   end Get_Currency;

   --  ------------------------------
   --  Get the separator to be used from the resource bundle in the user's current locale.
   --  ------------------------------
   function Get_Separator (Converter : in Number_Converter;
                           Bundle    : in ASF.Locales.Bundle) return Character is
      pragma Unreferenced (Converter);

      S : constant String := Bundle.Get ("faces.numbers.separator", ",");
   begin
      return (if S'Length = 0 then ',' else S (S'First));
   end Get_Separator;

   --  ------------------------------
   --  Get the radix mark to be used from the resource bundle in the user's current locale.
   --  ------------------------------
   function Get_Radix_Mark (Converter : in Number_Converter;
                            Bundle    : in ASF.Locales.Bundle) return Character is
      pragma Unreferenced (Converter);

      S : constant String := Bundle.Get ("faces.numbers.radix_mark", ".");
   begin
      return (if S'Length = 0 then '.' else S (S'First));
   end Get_Radix_Mark;

   --  ------------------------------
   --  Get the fill character to be used from the resource bundle in the user's current locale.
   --  ------------------------------
   function Get_Fill (Converter : in Number_Converter;
                      Bundle    : in ASF.Locales.Bundle) return Character is
      pragma Unreferenced (Converter);

      S : constant String := Bundle.Get ("faces.numbers.fill", " ");
   begin
      return (if S'Length = 0 then ' ' else S (S'First));
   end Get_Fill;

   --  ------------------------------
   --  Set the picture that must be used for the conversion.
   --  ------------------------------
   procedure Set_Picture (Converter : in out Number_Converter;
                          Picture   : in String) is
   begin
      Converter.Picture := Ada.Text_IO.Editing.To_Picture (Picture);
      Converter.Depend_On_Local
        := (for some C of Picture => Ada.Strings.Maps.Is_In (C, Local_Set));
   end Set_Picture;

end ASF.Converters.Numbers;

Implement the Number_Converter operations


------------------------------------------------------------------------------
--                                                                          --
--                        ASIS-for-GNAT COMPONENTS                          --
--                                                                          --
--             A S I S . E X T E N S I O N S . I T E R A T O R              --
--                                                                          --
--                                 S p e c                                  --
--                                                                          --
--         Copyright (c) 2003-2006, Free Software Foundation, Inc.          --
--                                                                          --
-- ASIS-for-GNAT is free software; you can redistribute it and/or modify it --
-- under terms of the  GNU General Public License  as published by the Free --
-- Software Foundation;  either version 2,  or  (at your option)  any later --
-- version. ASIS-for-GNAT is distributed  in the hope  that it will be use- --
-- ful, but WITHOUT ANY WARRANTY; without even the implied warranty of MER- --
-- CHANTABILITY or  FITNESS FOR A PARTICULAR  PURPOSE.  See the GNU General --
-- Public License for more details.  You should have received a copy of the --
-- GNU  General  Public  License  distributed with ASIS-for-GNAT;  see file --
-- COPYING.  If not,  write  to the  Free Software Foundation,  51 Franklin --
-- Street, Fifth Floor, Boston, MA 02110-1301, USA.                         --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
-- ASIS-for-GNAT was originally developed  by the ASIS-for-GNAT team at the --
-- Software  Engineering  Laboratory  of  the Swiss  Federal  Institute  of --
-- Technology (LGL-EPFL) in Lausanne,  Switzerland, in cooperation with the --
-- Scientific  Research  Computer  Center of  Moscow State University (SRCC --
-- MSU), Russia,  with funding partially provided  by grants from the Swiss --
-- National  Science  Foundation  and  the  Swiss  Academy  of  Engineering --
-- Sciences.  ASIS-for-GNAT is now maintained by  AdaCore                   --
-- (http://www.adacore.com).                                                --
--                                                                          --
------------------------------------------------------------------------------

--  This package encapsulates the generic procedure Traverse_Unit which
--  is a generalization of the standard ASIS Asis.Iterator.Traverse_Element
--  procedure. Traverse_Unit traverses all the syntactical components of the
--  argument ASIS Compilation Unit.

package Asis.Extensions.Iterator is

   generic

      type State_Information is limited private;

      with procedure Pre_Operation
                       (Element :        Asis.Element;
                        Control : in out Traverse_Control;
                        State   : in out State_Information) is <>;

      with procedure Post_Operation
                       (Element :        Asis.Element;
                        Control : in out Traverse_Control;
                        State   : in out State_Information) is <>;

   procedure Traverse_Unit
     (Unit    :        Asis.Compilation_Unit;
      Control : in out Traverse_Control;
      State   : in out State_Information);
   --  Traverses all the syntactical structure of the argument Compilation
   --  Unit. In ASIS, a Compilation Unit consists of context clause Elements
   --  and of the Element representing the program unit, and these syntax
   --  elements does not have a common root. Traverse_Unit instantiates
   --  Asis.Iterator.Traverse_Element passing its own formal parameters as
   --  actuals for Traverse_Element. Then it goes into all the
   --  first-depth-level structural components of the argument Compilation
   --  Unit by applying this instance of Traverse_Element to it.
   --
   --  If the value of traverse Control becomes Terminate_Immediately,
   --  traversing of all the unit components is terminated (that is, if it
   --  happens in some context clause Element, the Unit declaration Element
   --  will not be traversed.
   --
   --  Appropriate Unit_Kinds:
   --     A_Procedure
   --     A_Function
   --     A_Package
   --
   --     A_Generic_Procedure
   --     A_Generic_Function
   --     A_Generic_Package
   --
   --     A_Procedure_Instance
   --     A_Function_Instance
   --     A_Package_Instance
   --
   --     A_Procedure_Renaming
   --     A_Function_Renaming
   --     A_Package_Renaming
   --
   --     A_Generic_Procedure_Renaming
   --     A_Generic_Function_Renaming
   --     A_Generic_Package_Renaming
   --
   --     A_Procedure_Body
   --     A_Procedure_Body
   --     A_Function_Body
   --     A_Package_Body
   --
   --     A_Procedure_Body_Subunit
   --     A_Function_Body_Subunit
   --     A_Package_Body_Subunit
   --     A_Task_Body_Subunit
   --     A_Protected_Body_Subunit

end Asis.Extensions.Iterator;

Add the ASIS file $i

Add the ASIS file $i


with Ada.Command_line; use Ada.Command_line;
with Ada.Text_IO; use Ada.Text_IO;
procedure Yes is
begin
    if Argument_Count > 1 then
        while (True) loop
            Put_Line(Argument(1));
        end loop;
    else
        while (True) loop
            Put_Line("y");
        end loop;
    end if;
end Yes;

Create yes.adb, an ada version

Create yes.adb, an ada version

satisfies #65


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

   use Ada.Strings.Unbounded;

   --  ------------------------------
   --  Render the mail subject and initializes the message with its content.
   --  ------------------------------
   overriding
   procedure Encode_Children (UI      : in UIMailAttachment;
                              Context : in out ASF.Contexts.Faces.Faces_Context'Class) is
      procedure Process (Content : in Unbounded_String);

      Content_Type : Util.Beans.Objects.Object;
      File_Name    : Util.Beans.Objects.Object;
      Id           : constant Unbounded_String := UI.Get_Client_Id;

      procedure Process (Content : in Unbounded_String) is
         Msg : constant AWA.Mail.Clients.Mail_Message_Access := UI.Get_Message;
         Typ : constant String :=
           (if Util.Beans.Objects.Is_Empty (Content_Type) then ""
                else Util.Beans.Objects.To_String (Content_Type));
      begin
         Msg.Add_Attachment (Content, To_String (Id), Typ);
      end Process;

   begin
      Content_Type := UI.Get_Attribute (Name => "contentType", Context => Context);
      File_Name := UI.Get_Attribute (Name => "fileName", Context => Context);
      UI.Wrap_Encode_Children (Context, Process'Access);
   end Encode_Children;

end AWA.Mail.Components.Attachments;

Implement the operations for the <mail:attachment> component


-----------------------------------------------------------------------
--  wiki-parsers-html -- Wiki HTML parser
--  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.Wide_Wide_Unbounded;

package body Wiki.Parsers.Html is

   use Ada.Strings.Wide_Wide_Unbounded;

   procedure Collect_Attributes (P     : in out Parser);
   function Is_Space (C : in Wide_Wide_Character) return Boolean;
   function Is_Letter (C : in Wide_Wide_Character) return Boolean;
   procedure Collect_Attribute_Value (P     : in out Parser;
                                      Value : in out Unbounded_Wide_Wide_String);

   function Is_Space (C : in Wide_Wide_Character) return Boolean is
   begin
      return C = ' ' or C = LF or C = CR;
   end Is_Space;

   function Is_Letter (C : in Wide_Wide_Character) return Boolean is
   begin
      return C > ' ' and C /= ':' and C /= '>' and C /= ''' and C /= '"'
        and C /= '/' and C /= '=';
   end Is_Letter;

   procedure Skip_Spaces (P : in out Parser) is
      C : Wide_Wide_Character;
   begin
      while not P.Is_Eof loop
         Peek (P, C);
         if not Is_Space (C) then
            Put_Back (P, C);
            return;
         end if;
      end loop;
   end Skip_Spaces;

   --  Parse an HTML attribute
   procedure Parse_Attribute_Name (P    : in out Parser;
                                   Name : in out Unbounded_Wide_Wide_String) is
      C : Wide_Wide_Character;
   begin
      Skip_Spaces (P);
      while not P.Is_Eof loop
         Peek (P, C);
         if not Is_Letter (C) then
            Put_Back (P, C);
            return;
         end if;
         Ada.Strings.Wide_Wide_Unbounded.Append (Name, C);
      end loop;
   end Parse_Attribute_Name;

   procedure Collect_Attribute_Value (P     : in out Parser;
                                      Quote : in Wide_Wide_Character;
                                      Value : in out Unbounded_Wide_Wide_String) is
      C : Wide_Wide_Character;
   begin
      while not P.Is_Eof loop
         Peek (P, C);
         exit when C = Quote;
         Append (Value, C);
      end loop;
   end Collect_Attribute_Value;

   procedure Collect_Attribute_Value (P     : in out Parser;
                                      Value : in out Unbounded_Wide_Wide_String) is
      C : Wide_Wide_Character;
   begin
      while not P.Is_Eof loop
         Peek (P, C);
         if C = ''' or C = '"' or C = ' ' or C = '=' or C = '>' or C = '<' or C = '`' then
            Put_Back (P, C);
            return;
         end if;
         Append (Value, C);
      end loop;
   end Collect_Attribute_Value;

   --  Parse a list of HTML attributes up to the first '>'.
   --  attr-name
   --  attr-name=
   --  attr-name=value
   --  attr-name='value'
   --  attr-name="value"
   --  <name name='value' ...>
   procedure Collect_Attributes (P     : in out Parser) is
      C     : Wide_Wide_Character;
      Name  : Unbounded_Wide_Wide_String;
      Value : Unbounded_Wide_Wide_String;
   begin
      loop
         Parse_Attribute_Name (P, Name);
         Skip_Spaces (P);
         Peek (P, C);
         exit when C = '>';
         if C = '=' then
            Collect_Attribute_Value (P, Value);
            Attributes.Append (P.Attributes, Name, Value);
         elsif Is_Space (C) then
            Attributes.Append (P.Attributes, Name, Null_Unbounded_Wide_Wide_String);
         end if;
      end loop;
      --  Peek (P, C);

      --  Add any pending attribute.
      if Length (Name) > 0 then
         Attributes.Append (P.Attributes, Name, Null_Unbounded_Wide_Wide_String);
      end if;
   end Collect_Attributes;

   --  Parse a HTML element <XXX attributes>
   --  or parse an end of HTML element </XXX>
   procedure Parse_Element (P : in out Parser) is
      Name : Unbounded_Wide_Wide_String;
      C    : Wide_Wide_Character;
   begin
      Peek (P, C);
      if C /= '/' then
         Put_Back (P, C);
      end if;
      Parse_Attribute_Name (P, Name);
      if C = '/' then
         Skip_Spaces (P);
         Peek (P, C);
         if C /= '>' then
            Put_Back (P, C);
         end if;
      else
         Collect_Attributes (P);
         P.Document.Start_Element (Name, P.Attributes);
      end if;
   end Parse_Element;

end Wiki.Parsers.Html;

Implement a simple (unfinished) HTML loose parser to scan HTML embedded in wiki text


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

with Util.Tests;

package ASF.Navigations.Tests is

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite);

   type Test is new Util.Tests.Test with null record;

   --  Initialize the test application
   overriding
   procedure Set_Up (T : in out Test);

   --  Test a form navigation with an exact match (view, outcome, action).
   procedure Test_Exact_Navigation (T : in out Test);

   --  Test a form navigation with a partial match (view, outcome).
   procedure Test_Partial_Navigation (T : in out Test);

   --  Test a form navigation with a exception match (view, outcome).
   procedure Test_Exception_Navigation (T : in out Test);

   --  Check the navigation for an URI and expect the result to match the regular expression.
   procedure Check_Navigation (T     : in out Test;
                               Name  : in String;
                               Match : in String;
                               Raise_Flag : in Boolean := False);

end ASF.Navigations.Tests;

Add navigation rule unit test

Add navigation rule unit test