------------------------------------------------------------------------------
--                                                                          --
--                   ASIS-for-GNAT INTERFACE COMPONENTS                     --
--                                                                          --
--                  A S I S . I M P L E M E N T A T I O N                   --
--                                                                          --
--                                 S p e c                                  --
--                                                                          --
--           Copyright (c) 2006, Free Software Foundation, Inc.             --
--                                                                          --
-- This   specification  is  adapted   from  the  Ada   Semantic  Interface --
-- Specification Standard (ISO/IEC 15291) for use with GNAT.  In accordance --
-- with the copyright of that document, you can freely copy and modify this --
-- specification, provided that if you redistribute a modified version, any --
-- changes  that  you have made are clearly indicated. The copyright notice --
-- above,  and  the  license  provisions  that  follow  apply solely to the --
-- contents of the part following the private keyword.                      --
--                                                                          --
-- 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).                                                --
--                                                                          --
------------------------------------------------------------------------------

------------------------------------------------------------------------------
--  6  package Asis.Implementation
------------------------------------------------------------------------------
------------------------------------------------------------------------------
with Asis.Errors;
package Asis.Implementation is
------------------------------------------------------------------------------
------------------------------------------------------------------------------
--  Asis.Implementation provides queries to initialize, finalize, and query the
--  error status of the ASIS Implementation.
------------------------------------------------------------------------------
------------------------------------------------------------------------------

------------------------------------------------------------------------------
--  6.1   function ASIS_Version
------------------------------------------------------------------------------

   function ASIS_Version return Wide_String;

------------------------------------------------------------------------------
--  6.2   function ASIS_Implementor
------------------------------------------------------------------------------

   function ASIS_Implementor return Wide_String;

------------------------------------------------------------------------------
--  6.3   function ASIS_Implementor_Version
------------------------------------------------------------------------------

   function ASIS_Implementor_Version return Wide_String;

------------------------------------------------------------------------------
--  6.4   function ASIS_Implementor_Information
------------------------------------------------------------------------------

   function ASIS_Implementor_Information return Wide_String;

------------------------------------------------------------------------------
--  Returns values which identify:
--
--   ASIS_Version                 - the version of the ASIS interface,
--                                  e.g., "2.1"
--   ASIS_Implementor             - the name of the implementor,
--                                  e.g., "Ada Inc."
--   ASIS_Implementor_Version     - the implementation's version,
--                                  e.g., "5.2a"
--   ASIS_Implementor_Information - implementation information,
--                                  e.g., "Copyright ..."
--
------------------------------------------------------------------------------
--  6.5   function Is_Initialized
------------------------------------------------------------------------------

   function Is_Initialized return Boolean;

------------------------------------------------------------------------------
--  Returns True if ASIS is currently initialized.
--
------------------------------------------------------------------------------
--  6.6   procedure Initialize
------------------------------------------------------------------------------

   procedure Initialize (Parameters : Wide_String := "");

------------------------------------------------------------------------------
--  Parameters  - Specifies implementation specific parameters.
--
--  Performs any necessary initialization activities.  This shall be invoked
--  at least once before any other ASIS services are used.  Parameter values
--  are implementation dependent.  The call is ignored if ASIS is already
--  initialized. All ASIS queries and services are ready for use once this
--  call completes.
--
--  Raises ASIS_Failed if ASIS failed to initialize or if the Parameters
--  argument is invalid.  Status is Environment_Error or Parameter_Error.
--
--  --|AN Application Note:
--  --|AN
--  --|AN The ASIS implementation may be Initialized and Finalized any number
--  --|AN of times during the operation of an ASIS program. However, all
--  --|AN existing Context, Compilation_Unit and Element values become invalid
--  --|AN when ASIS Is_Finalized. Subsequent calls to ASIS queries or services
--  --|AN using such invalid Compilation_Unit or Element values will cause
--  --|AN ASIS_Inappropriate_Context to be raised.
--
------------------------------------------------------------------------------
--  6.7   function Is_Finalized
------------------------------------------------------------------------------

   function Is_Finalized return Boolean;

------------------------------------------------------------------------------
--  Returns True if ASIS is currently finalized or if ASIS has never been
--  initialized.
--
------------------------------------------------------------------------------
--  6.8   procedure Finalize
------------------------------------------------------------------------------

   procedure Finalize (Parameters : Wide_String := "");

------------------------------------------------------------------------------
--  Parameters  - Specifies any implementation required parameter values.
--
--  Performs any necessary ASIS termination activities.  This should be invoked
--  once following the last use of other ASIS queries.  Parameter values are
--  implementation dependent. The call is ignored if ASIS is already finalized.
--  Subsequent calls to ASIS Environment, Compilation_Unit, and Element
--  queries, are erroneous while the environment Is_Finalized.
--
--  Raises ASIS_Failed if the ASIS implementation failed to finalize.  Status
--  is likely to be Internal_Error and will not be Not_An_Error.
--
-------------------------------------------------------------------------------
--  Whenever an error condition is detected, and any ASIS exception is raised,
--  an Asis.Errors.Error_Kinds value and a Diagnosis string is stored.  These
--  values can be retrieved by the Status and Diagnosis functions.  The
--  Diagnosis function will retrieve the diagnostic message describing the
--  error.
--
--  Error information always refers to the most recently recorded error.
--
--  Note that Diagnosis values are implementation dependent and may vary
--  greatly among ASIS implementations.
--
------------------------------------------------------------------------------
--  6.9   function Status
------------------------------------------------------------------------------

   function Status return Asis.Errors.Error_Kinds;

------------------------------------------------------------------------------
--  Returns the Error_Kinds value for the most recent error.
--
------------------------------------------------------------------------------
--  6.10  function Diagnosis
------------------------------------------------------------------------------

   function Diagnosis return Wide_String;

------------------------------------------------------------------------------
--  Returns a string value describing the most recent error.
--
--  Will typically return a null string if Status = Not_An_Error.
--
------------------------------------------------------------------------------
--  6.11  procedure Set_Status
------------------------------------------------------------------------------

   procedure Set_Status
     (Status    : Asis.Errors.Error_Kinds := Asis.Errors.Not_An_Error;
      Diagnosis : Wide_String             := "");

------------------------------------------------------------------------------
--  Status      - Specifies the new status to be recorded
--  Diagnosis   - Specifies the new diagnosis to be recorded
--
--  Sets (clears, if the defaults are used) the Status and Diagnosis
--  information.  Future calls to Status will return this Status (Not_An_Error)
--  and this Diagnosis (a null string).
--
--  Raises ASIS_Failed, with a Status of Internal_Error and a Diagnosis of
--  a null string, if the Status parameter is Not_An_Error and the Diagnosis
--  parameter is not a null string.
--
------------------------------------------------------------------------------
--
end Asis.Implementation;

Add the ASIS file $i

Add the ASIS file $i


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

with Util.Tests;
with Util.Test_Caller;

package body Util.Events.Timers.Tests is

   use Util.Tests;
   use type Ada.Real_Time.Time;

   package Caller is new Util.Test_Caller (Test, "Events.Timers");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Util.Events.Channels.Post_Event",
                       Test_Timer_Event'Access);
   end Add_Tests;

   overriding
   procedure Time_Handler (Sub   : in out Test;
                           Event : in out Timer_Ref'Class) is
   begin
      Sub.Count := Sub.Count + 1;
   end Time_Handler;

   procedure Test_Timer_Event (T : in out Test) is
      M        : Timer_List;
      R        : Timer_Ref;
      Start    : Ada.Real_Time.Time := Ada.Real_Time.Clock;
      Deadline : Ada.Real_Time.Time;
      Now      : Ada.Real_Time.Time;
   begin
      T.Assert (not R.Is_Scheduled, "Empty timer should not be scheduled");
      for Retry in 1 .. 10 loop
         M.Set_Timer (T'Unchecked_Access, R, Start + Ada.Real_Time.Milliseconds (10));
         M.Process (Deadline);
         Now := Ada.Real_Time.Clock;
         exit when Now < Deadline;
      end loop;
      T.Assert (Now < Deadline, "The timer deadline is not correct");
      delay until Deadline;
      M.Process (Deadline);
      Assert_Equals (T, 1, T.Count, "The timer handler was not called");
   end Test_Timer_Event;

end Util.Events.Timers.Tests;

Implement the new unit tests for the timer management


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

with Ada.Unchecked_Deallocation;
package body Util.Http.Clients is

   --  ------------------------------
   --  Returns a boolean indicating whether the named response header has already
   --  been set.
   --  ------------------------------
   overriding
   function Contains_Header (Reply : in Response;
                             Name  : in String) return Boolean is
   begin
      if Reply.Delegate = null then
         return False;
      else
         return Reply.Delegate.Contains_Header (Name);
      end if;
   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.
   --  ------------------------------
   overriding
   function Get_Header (Reply  : in Response;
                        Name   : in String) return String is
   begin
      if Reply.Delegate = null then
         return "";
      else
         return Reply.Delegate.Get_Header (Name);
      end if;
   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 Response;
                         Name     : in String;
                         Value    : in String) is
   begin
      Reply.Delegate.Set_Header (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 (Reply   : in out Response;
                         Name    : in String;
                         Value   : in String) is
   begin
      Reply.Delegate.Add_Header (Name, Value);
   end Add_Header;

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

   --  ------------------------------
   --  Get the response body as a string.
   --  ------------------------------
   overriding
   function Get_Body (Reply : in Response) return String is
   begin
      if Reply.Delegate = null then
         return "";
      else
         return Reply.Delegate.Get_Body;
      end if;
   end Get_Body;

   --  ------------------------------
   --  Get the response status code.
   --  ------------------------------
   function Get_Status (Reply : in Response) return Natural is
   begin
      return Reply.Delegate.Get_Status;
   end Get_Status;

   --  ------------------------------
   --  Returns a boolean indicating whether the named response header has already
   --  been set.
   --  ------------------------------
   overriding
   function Contains_Header (Request : in Client;
                             Name    : in String) return Boolean is
   begin
      if Request.Delegate = null then
         return False;
      else
         return Request.Delegate.Contains_Header (Name);
      end if;
   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 Client;
                        Name    : in String) return String is
   begin
      if Request.Delegate = null then
         return "";
      else
         return Request.Delegate.Get_Header (Name);
      end if;
   end Get_Header;

   --  ------------------------------
   --  Sets a 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 (Request  : in out Client;
                         Name     : in String;
                         Value    : in String) is
   begin
      Request.Delegate.Set_Header (Name, Value);
   end Set_Header;

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

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

   --  ------------------------------
   --  Removes all headers with the given name.
   --  ------------------------------
   procedure Remove_Header (Request : in out Client;
                            Name    : in String) is
   begin
      null;
   end Remove_Header;

   --  ------------------------------
   --  Initialize the client
   --  ------------------------------
   overriding
   procedure Initialize (Http : in out Client) is
   begin
      Http.Delegate := null;
      Http.Manager  := Default_Http_Manager;
      Http.Manager.Create (Http);
   end Initialize;

   overriding
   procedure Finalize (Http : in out Client) is
      procedure Free is new Ada.Unchecked_Deallocation (Http_Request'Class,
                                                        Http_Request_Access);
   begin
      Free (Http.Delegate);
   end Finalize;

   --  ------------------------------
   --  Execute an http GET request on the given URL.  Additional request parameters,
   --  cookies and headers should have been set on the client object.
   --  ------------------------------
   procedure Get (Request  : in out Client;
                  URL      : in String;
                  Reply    : out Response'Class) is
   begin
      Request.Manager.Do_Get (Request, URL, Reply);
   end Get;

   --  ------------------------------
   --  Execute an http POST request on the given URL.  The post data is passed in Data.
   --  Additional request cookies and headers should have been set on the client object.
   --  ------------------------------
   procedure Post (Request : in out Client;
                   URL     : in String;
                   Data    : in String;
                   Reply   : out Response'Class) is
   begin
      Request.Manager.Do_Post (Request, URL, Data, Reply);
   end Post;

   --  ------------------------------
   --  Adds the specified cookie to the request. This method can be called multiple
   --  times to set more than one cookie.
   --  ------------------------------
   procedure Add_Cookie (Http   : in out Client;
                         Cookie : in Util.Http.Cookies.Cookie) is
   begin
      null;
   end Add_Cookie;

   --  ------------------------------
   --  Free the resource used by the response.
   --  ------------------------------
   overriding
   procedure Finalize (Reply : in out Response) is
      procedure Free is new Ada.Unchecked_Deallocation (Http_Response'Class,
                                                        Http_Response_Access);
   begin
      Free (Reply.Delegate);
   end Finalize;

end Util.Http.Clients;

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

with Ada.Unchecked_Deallocation;
with Util.Log.Loggers;
package body Util.Http.Clients is

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

   --  ------------------------------
   --  Returns a boolean indicating whether the named response header has already
   --  been set.
   --  ------------------------------
   overriding
   function Contains_Header (Reply : in Response;
                             Name  : in String) return Boolean is
   begin
      if Reply.Delegate = null then
         return False;
      else
         return Reply.Delegate.Contains_Header (Name);
      end if;
   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.
   --  ------------------------------
   overriding
   function Get_Header (Reply  : in Response;
                        Name   : in String) return String is
   begin
      if Reply.Delegate = null then
         return "";
      else
         return Reply.Delegate.Get_Header (Name);
      end if;
   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 Response;
                         Name     : in String;
                         Value    : in String) is
   begin
      Reply.Delegate.Set_Header (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 (Reply   : in out Response;
                         Name    : in String;
                         Value   : in String) is
   begin
      Reply.Delegate.Add_Header (Name, Value);
   end Add_Header;

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

   --  ------------------------------
   --  Get the response body as a string.
   --  ------------------------------
   overriding
   function Get_Body (Reply : in Response) return String is
   begin
      if Reply.Delegate = null then
         return "";
      else
         return Reply.Delegate.Get_Body;
      end if;
   end Get_Body;

   --  ------------------------------
   --  Get the response status code.
   --  ------------------------------
   function Get_Status (Reply : in Response) return Natural is
   begin
      return Reply.Delegate.Get_Status;
   end Get_Status;

   --  ------------------------------
   --  Returns a boolean indicating whether the named response header has already
   --  been set.
   --  ------------------------------
   overriding
   function Contains_Header (Request : in Client;
                             Name    : in String) return Boolean is
   begin
      if Request.Delegate = null then
         return False;
      else
         return Request.Delegate.Contains_Header (Name);
      end if;
   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 Client;
                        Name    : in String) return String is
   begin
      if Request.Delegate = null then
         return "";
      else
         return Request.Delegate.Get_Header (Name);
      end if;
   end Get_Header;

   --  ------------------------------
   --  Sets a 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 (Request  : in out Client;
                         Name     : in String;
                         Value    : in String) is
   begin
      Request.Delegate.Set_Header (Name, Value);
   end Set_Header;

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

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

   --  ------------------------------
   --  Removes all headers with the given name.
   --  ------------------------------
   procedure Remove_Header (Request : in out Client;
                            Name    : in String) is
   begin
      null;
   end Remove_Header;

   --  ------------------------------
   --  Initialize the client
   --  ------------------------------
   overriding
   procedure Initialize (Http : in out Client) is
   begin
      Http.Delegate := null;
      Http.Manager  := Default_Http_Manager;
      if Http.Manager = null then
         Log.Error ("No HTTP manager was defined");
         raise Program_Error with "No HTTP manager was defined.";
      end if;
      Http.Manager.Create (Http);
   end Initialize;

   overriding
   procedure Finalize (Http : in out Client) is
      procedure Free is new Ada.Unchecked_Deallocation (Http_Request'Class,
                                                        Http_Request_Access);
   begin
      Free (Http.Delegate);
   end Finalize;

   --  ------------------------------
   --  Execute an http GET request on the given URL.  Additional request parameters,
   --  cookies and headers should have been set on the client object.
   --  ------------------------------
   procedure Get (Request  : in out Client;
                  URL      : in String;
                  Reply    : out Response'Class) is
   begin
      Request.Manager.Do_Get (Request, URL, Reply);
   end Get;

   --  ------------------------------
   --  Execute an http POST request on the given URL.  The post data is passed in Data.
   --  Additional request cookies and headers should have been set on the client object.
   --  ------------------------------
   procedure Post (Request : in out Client;
                   URL     : in String;
                   Data    : in String;
                   Reply   : out Response'Class) is
   begin
      Request.Manager.Do_Post (Request, URL, Data, Reply);
   end Post;

   --  ------------------------------
   --  Adds the specified cookie to the request. This method can be called multiple
   --  times to set more than one cookie.
   --  ------------------------------
   procedure Add_Cookie (Http   : in out Client;
                         Cookie : in Util.Http.Cookies.Cookie) is
   begin
      null;
   end Add_Cookie;

   --  ------------------------------
   --  Free the resource used by the response.
   --  ------------------------------
   overriding
   procedure Finalize (Reply : in out Response) is
      procedure Free is new Ada.Unchecked_Deallocation (Http_Response'Class,
                                                        Http_Response_Access);
   begin
      Free (Reply.Delegate);
   end Finalize;

end Util.Http.Clients;

Add a log error and raise an exception if there is no http implementation selected


------------------------------------------------------------------------------
--                                                                          --
--                 ASIS-for-GNAT IMPLEMENTATION COMPONENTS                  --
--                                                                          --
--                             A S I S . I D S                              --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--            Copyright (C) 1995-2010, 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,  59 Temple Place --
-- - Suite 330,  Boston, MA 02111-1307, 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  Ada Core Technologies Inc --
-- (http://www.gnat.com).                                                   --
--                                                                          --
------------------------------------------------------------------------------
with Ada.Characters.Handling; use Ada.Characters.Handling;

with A4G.Vcheck; use A4G.Vcheck;

package body Asis.Ids is
------------------------------------------------------------------------------
--  NOT IMPLEMENTED

   function Hash (The_Id : Id) return Asis.ASIS_Integer is
   begin
      pragma Unreferenced (The_Id);
      Raise_ASIS_Failed (Diagnosis => "Asis.Ids.Hash");
      return 0;
   end Hash;
-----------------------------------------------------------------------------
--  NOT IMPLEMENTED

   function "<" (Left  : Id;
                 Right : Id) return Boolean is
   begin
      pragma Unreferenced (Left);
      pragma Unreferenced (Right);
      Raise_ASIS_Failed (Diagnosis => "Asis.Ids.""<""");
      return True;
   end "<";
-----------------------------------------------------------------------------
--  NOT IMPLEMENTED

   function ">" (Left  : Id;
                 Right : Id) return Boolean is
   begin
      pragma Unreferenced (Left);
      pragma Unreferenced (Right);
      Raise_ASIS_Failed (Diagnosis => "Asis.Ids."">""");
      return False;
   end ">";
-----------------------------------------------------------------------------
--  NOT IMPLEMENTED

   function Is_Nil (Right : Id) return Boolean is
   begin
      pragma Unreferenced (Right);
      Raise_ASIS_Failed (Diagnosis => "Asis.Ids.Is_Nil");
      return True;
   end Is_Nil;
-----------------------------------------------------------------------------
--  NOT IMPLEMENTED

   function Is_Equal
     (Left  : Id;
      Right : Id)
      return Boolean
   is
   begin
      pragma Unreferenced (Left);
      pragma Unreferenced (Right);
      Raise_ASIS_Failed (Diagnosis => "Asis.Ids.Is_Equal");
      return True;
   end Is_Equal;
-----------------------------------------------------------------------------
--  NOT IMPLEMENTED

   function Create_Id (Element : Asis.Element) return Id is
   begin
      pragma Unreferenced (Element);
      Raise_ASIS_Failed (Diagnosis => "Asis.Ids.Create_Id");
      return Nil_Id;
   end Create_Id;
-----------------------------------------------------------------------------
--  NOT IMPLEMENTED

   function Create_Element
     (The_Id      : Id;
      The_Context : Asis.Context)
      return Asis.Element
   is
   begin
      pragma Unreferenced (The_Id);
      pragma Unreferenced (The_Context);
      Raise_ASIS_Failed (Diagnosis => "Asis.Ids.Create_Element");
      return Nil_Element;
   end Create_Element;
-----------------------------------------------------------------------------
--  NOT IMPLEMENTED

   function Debug_Image (The_Id : Id) return Wide_String is
   begin

      if Is_Nil (The_Id) then
         return Nil_Asis_Wide_String;
      else
         return To_Wide_String (The_Id.all);
      end if;

   end Debug_Image;
-----------------------------------------------------------------------------
end Asis.Ids;

Add the ASIS file $i

Add the ASIS file $i


-----------------------------------------------------------------------
--  wiki-filters -- Wiki filters
--  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;
with Ada.Finalization;

with Wiki.Attributes;
with Wiki.Documents;

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

   pragma Preelaborate;

   use Ada.Strings.Wide_Wide_Unbounded;

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

   --  Add a section header in the document.
   overriding
   procedure Add_Header (Document : in out Filter_Type;
                         Header   : in Unbounded_Wide_Wide_String;
                         Level    : in Positive);

   --  Add a line break (
).
   overriding
   procedure Add_Line_Break (Document : in out Filter_Type);

   --  Add a paragraph (
).  Close the previous paragraph if any.
   --  The paragraph must be closed at the next paragraph or next header.
   overriding
   procedure Add_Paragraph (Document : in out Filter_Type);

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

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

   --  Add an horizontal rule (
).
   overriding
   procedure Add_Horizontal_Rule (Document : in out Filter_Type);

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

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

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

   --  Add a text block with the given format.
   overriding
   procedure Add_Text (Document : in out Filter_Type;
                       Text     : in Unbounded_Wide_Wide_String;
                       Format   : in Wiki.Documents.Format_Map);

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

   overriding
   procedure Start_Element (Document   : in out Filter_Type;
                            Name       : in Unbounded_Wide_Wide_String;
                            Attributes : in Wiki.Attributes.Attribute_List_Type);

   overriding
   procedure End_Element (Document : in out Filter_Type;
                          Name     : in Unbounded_Wide_Wide_String);

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

   --  Set the document reader.
   procedure Set_Document (Filter   : in out Filter_Type;
                           Document : in Wiki.Documents.Document_Reader_Access);

private

   type Filter_Type is new Ada.Finalization.Limited_Controlled
     and Wiki.Documents.Document_Reader with record
      Document : Wiki.Documents.Document_Reader_Access;
   end record;

end Wiki.Filters;

Add some documentation

Add some documentation


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

--  === Conditions Plugins ===
--  The <b>Wiki.Plugins.Conditions</b> package defines a set of conditional plugins
--  to show or hide wiki content according to some conditions evaluated during the parsing phase.
--
package Wiki.Plugins.Conditions is

   MAX_CONDITION_DEPTH : constant Natural := 31;

   type Condition_Depth is new Natural range 0 .. MAX_CONDITION_DEPTH;

   type Condition_Type is (CONDITION_IF, CONDITION_ELSIF, CONDITION_ELSE, CONDITION_END);

   type Condition_Plugin is new Wiki_Plugin with private;

   --  Evaluate the condition and return it as a boolean status.
   function Evaluate (Plugin   : in Condition_Plugin;
                      Params   : in Wiki.Attributes.Attribute_List) return Boolean;

   --  Get the type of condition (IF, ELSE, ELSIF, END) represented by the plugin.
   function Get_Condition_Kind (Plugin : in Condition_Plugin;
                                Params : in Wiki.Attributes.Attribute_List)
                                return Condition_Type;

   --  Evaluate the condition described by the parameters and hide or show the wiki
   --  content.
   overriding
   procedure Expand (Plugin   : in out Condition_Plugin;
                     Document : in out Wiki.Documents.Document;
                     Params   : in out Wiki.Attributes.Attribute_List;
                     Context  : in Plugin_Context);

   --  Append the attribute name/value to the condition plugin parameter list.
   procedure Append (Plugin   : in out Condition_Plugin;
                     Name     : in Wiki.Strings.WString;
                     Value    : in Wiki.Strings.WString);

private

   type Boolean_Array is array (Condition_Depth) of Boolean;
   pragma Pack (Boolean_Array);

   type Condition_Plugin is new Wiki_Plugin with record
      Depth  : Condition_Depth := 1;
      Values : Boolean_Array := (others => False);
      Params : Wiki.Attributes.Attribute_List;
   end record;

end Wiki.Plugins.Conditions;

Declare the Conditions package with the Condition_Plugin type for the support of conditional inclusion in wiki text


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

package body Wiki.Streams.Html.Builders is

   --  Close the current XML entity if an entity was started
   procedure Close_Current (Stream : in out Html_Output_Builder_Stream'Class);

   --  Internal method to write a character on the response stream
   --  and escape that character as necessary.  Unlike 'Write_Char',
   --  this operation does not closes the current XML entity.
   procedure Write_Escape (Stream : in out Html_Output_Builder_Stream'Class;
                           Char   : in Wide_Wide_Character);

   type Unicode_Char is mod 2**31;

   --  ------------------------------
   --  Internal method to write a character on the response stream
   --  and escape that character as necessary.  Unlike 'Write_Char',
   --  this operation does not closes the current XML entity.
   --  ------------------------------
   procedure Write_Escape (Stream : in out Html_Output_Builder_Stream'Class;
                           Char   : in Wide_Wide_Character) is
      Code : constant Unicode_Char := Wide_Wide_Character'Pos (Char);
   begin
      --  If "?" or over, no escaping is needed (this covers
      --  most of the Latin alphabet)
      if Code > 16#3F# or Code <= 16#20# then
         Stream.Write (Char);
      elsif Char = '<' then
         Stream.Write ("<");
      elsif Char = '>' then
         Stream.Write (">");
      elsif Char = '&' then
         Stream.Write ("&");
      else
         Stream.Write (Char);
      end if;
   end Write_Escape;

   --  ------------------------------
   --  Close the current XML entity if an entity was started
   --  ------------------------------
   procedure Close_Current (Stream : in out Html_Output_Builder_Stream'Class) is
   begin
      if Stream.Close_Start then
         Stream.Write ('>');
         Stream.Close_Start := False;
      end if;
   end Close_Current;

   procedure Write_Wide_Element (Stream  : in out Html_Output_Builder_Stream;
                                 Name    : in String;
                                 Content : in Wiki.Strings.WString) is

   begin
      Stream.Start_Element (Name);
      Stream.Write_Wide_Text (Content);
      Stream.End_Element (Name);
   end Write_Wide_Element;

   --  ------------------------------
   --  Write an XML attribute within an XML element.
   --  The attribute value is escaped according to the XML escape rules.
   --  ------------------------------
   procedure Write_Wide_Attribute (Stream  : in out Html_Output_Builder_Stream;
                                   Name    : in String;
                                   Content : in Wiki.Strings.WString) is
   begin
      if Stream.Close_Start then
         Stream.Write (' ');
         Stream.Write_String (Name);
         Stream.Write ('=');
         Stream.Write ('"');
         for I in Content'Range loop
            declare
               C : constant Wide_Wide_Character := Content (I);
            begin
               if C = '"' then
                  Stream.Write (""");
               else
                  Stream.Write_Escape (C);
               end if;
            end;
         end loop;
         Stream.Write ('"');
      end if;
   end Write_Wide_Attribute;

   procedure Write_Wide_Attribute (Stream  : in out Html_Output_Builder_Stream;
                                   Name    : in String;
                                   Content : in Unbounded_Wide_Wide_String) is
      Count : constant Natural := Length (Content);
   begin
      if Stream.Close_Start then
         Stream.Write (' ');
         Stream.Write_String (Name);
         Stream.Write ('=');
         Stream.Write ('"');
         for I in 1 .. Count loop
            declare
               C : constant Wide_Wide_Character := Element (Content, I);
            begin
               if C = '"' then
                  Stream.Write (""");
               else
                  Stream.Write_Escape (C);
               end if;
            end;
         end loop;
         Stream.Write ('"');
      end if;
   end Write_Wide_Attribute;

   procedure Start_Element (Stream : in out Html_Output_Builder_Stream;
                            Name   : in String) is
   begin
      Close_Current (Stream);
      Stream.Write ('<');
      Stream.Write_String (Name);
      Stream.Close_Start := True;
   end Start_Element;

   procedure End_Element (Stream : in out Html_Output_Builder_Stream;
                          Name   : in String) is
   begin
      if Stream.Close_Start then
         Stream.Write (" />");
         Stream.Close_Start := False;
      else
         Close_Current (Stream);
         Stream.Write ("</");
         Stream.Write_String (Name);
         Stream.Write ('>');
      end if;
   end End_Element;

   procedure Write_Wide_Text (Stream  : in out Html_Output_Builder_Stream;
                              Content : in Wiki.Strings.WString) is
   begin
      Close_Current (Stream);
      for I in Content'Range loop
         Html_Output_Builder_Stream'Class (Stream).Write_Escape (Content (I));
      end loop;
   end Write_Wide_Text;

end Wiki.Streams.Html.Builders;

Implement the Wiki.Streams.Html.Builders package


-----------------------------------------------------------------------
--  asf-rest -- REST Support
--  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.
-----------------------------------------------------------------------

package body ASF.Rest is

   --  ------------------------------
   --  Get the permission index associated with the REST operation.
   --  ------------------------------
   function Get_Permission (Handler : in Descriptor)
                            return Security.Permissions.Permission_Index is
   begin
      return Handler.Permission;
   end Get_Permission;

   --  ------------------------------
   --  Register the API descriptor in a list.
   --  ------------------------------
   procedure Register (List : in out Descriptor_Access;
                       Item : in Descriptor_Access) is
   begin
      Item.Next := Item;
      List := Item;
   end Register;

end ASF.Rest;

Implement the Get_Permission and Register operations


-----------------------------------------------------------------------
--  babel-base-text-tests - Unit tests for babel text database
--  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.Test_Caller;

package body Babel.Base.Text.Tests is

   package Caller is new Util.Test_Caller (Test, "Base.Users");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Babel.Base.Text.Load",
                       Test_Load'Access);
   end Add_Tests;

   --  Test the loading a text database.
   procedure Test_Load (T : in out Test) is
      DB : Text_Database;
   begin
      DB.Load (Util.Tests.Get_Path ("regtests/files/db/database.txt"));
   end Test_Load;

end Babel.Base.Text.Tests;

Add Test_Load operation

Add Test_Load operation


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

with AUnit.Test_Suites;
with AUnit.Test_Fixtures;

package Util.Serialize.IO.XML.Tests is

   procedure Add_Tests (Suite : AUnit.Test_Suites.Access_Test_Suite);

   type Test is new AUnit.Test_Fixtures.Test_Fixture with null record;

   procedure Test_Parser (T : in out Test);

   procedure Test_Writer (T : in out Test);

end Util.Serialize.IO.XML.Tests;

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

with AUnit.Test_Suites;
with AUnit.Test_Fixtures;

package Util.Serialize.IO.XML.Tests is

   procedure Add_Tests (Suite : AUnit.Test_Suites.Access_Test_Suite);

   type Test is new AUnit.Test_Fixtures.Test_Fixture with null record;

   --  Test XML de-serialization
   procedure Test_Parser (T : in out Test);

   --  Test XML serialization
   procedure Test_Writer (T : in out Test);

end Util.Serialize.IO.XML.Tests;

Add comment

Add comment


-----------------------------------------------------------------------
--  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.Tests;
package ADO.Drivers.Tests is

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

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

   --  Test the Get_Config operation.
   procedure Test_Get_Config (T : in out Test);

   --  Test the Get_Driver operation.
   procedure Test_Get_Driver (T : in out Test);

   --  Test loading some invalid database driver.
   procedure Test_Load_Invalid_Driver (T : in out Test);

   --  Test the Get_Driver_Index operation.
   procedure Test_Get_Driver_Index (T : in out Test);

end ADO.Drivers.Tests;

Define some new tests for the database drivers support


------------------------------------------------------------------------------
--                                                                          --
--                 ASIS-for-GNAT IMPLEMENTATION COMPONENTS                  --
--                                                                          --
--                          A 4 G . A _ O S I N T                           --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--            Copyright (c) 1995-1999, 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,  59 Temple Place --
-- - Suite 330,  Boston, MA 02111-1307, 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  Ada Core Technologies Inc --
-- (http://www.gnat.com).                                                   --
--                                                                          --
------------------------------------------------------------------------------

with Unchecked_Deallocation;

package body A4G.A_Osint is

   -----------------------
   -- Local subprograms --
   -----------------------

   procedure Free_String is new Unchecked_Deallocation (String, String_Access);

   procedure Free_List is new Unchecked_Deallocation
     (Argument_List, Argument_List_Access);

   ------------------------
   -- Free_Argument_List --
   ------------------------

   procedure Free_Argument_List (List : in out Argument_List_Access) is
   begin
      if List = null then
         return;
      end if;

      for J in List'Range loop
         Free_String (List (J));
      end loop;

      Free_List (List);
   end Free_Argument_List;

   ------------------------------
   -- Get_Max_File_Name_Length --
   ------------------------------

   function Get_Max_File_Name_Length return Int is
      function Get_Maximum_File_Name_Length return Int;
      pragma Import (C, Get_Maximum_File_Name_Length,
                    "__gnat_get_maximum_file_name_length");
      --  This function does what we want, but it returns -1 when there
      --  is no restriction on the file name length
      --
      --  The implementation has been "stolen" from the body of GNAT
      --  Osint.Initialize

   begin
      if Get_Maximum_File_Name_Length = -1 then
         return Int'Last;
      else
         return Get_Maximum_File_Name_Length;
      end if;
   end Get_Max_File_Name_Length;

   ------------------------------
   -- Normalize_Directory_Name --
   ------------------------------

   function Normalize_Directory_Name
     (Directory : String)
      return String
   is
   begin
      --  For now this just insures that the string is terminated with
      --  the directory separator character. Add more later?

      if Directory (Directory'Last) = Directory_Separator then
         return Directory;
      elsif Directory'Length = 0 then
         --  now we do not need this, but it is no harm to keep it
         return '.' & Directory_Separator;
      else
         return Directory & Directory_Separator;
      end if;
   end Normalize_Directory_Name;

end A4G.A_Osint;

Add the ASIS file $i

Add the ASIS file $i


------------------------------------------------------------------------------
--                                                                          --
--                 ASIS-for-GNAT IMPLEMENTATION COMPONENTS                  --
--                                                                          --
--        A S I S . D A T A _ D E C O M P O S I T I O N . V C H E C K       --
--                                                                          --
--                                 S p e c                                  --
--                                                                          --
--            Copyright (c) 1995-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 contains validity checks for abstractions declared in
--  Asis.Data_Decomposition (see 22.1, 22.3)

private package Asis.Data_Decomposition.Vcheck is

   type Component_Kinds is (Not_A_Component, Arr, Rec);

   procedure Check_Validity
     (Comp  : Record_Component;
      Query : String);
   --  Checks if Comp is valid in a sense as defined in 22.1. Raises
   --  Asis_Failed and sets the corresponding error status and diagnosis in
   --  case if the check fails. The Query parameter is supposed to be the name
   --  of the query where the check is performad.

   procedure Check_Validity
     (Comp  : Array_Component;
      Query : String);
   --  Checks if Comp is valid in a sense as defined in 22.3. Raises
   --  Asis_Failed and sets the corresponding error status and diagnosis in
   --  case if the check fails. The Query parameter is supposed to be the name
   --  of the query where the check is performad.

   procedure Raise_ASIS_Inappropriate_Component
     (Diagnosis      : String;
      Component_Kind : Component_Kinds);
   --  Raises ASIS_Inappropriate_Element with Value_Error Error Status.
   --  Diagnosis usially is the name of the query where the exception is
   --  raised. Component_Kind, if not equal to Not_A_Component, is used to put
   --  in the ASIS diagnosis string some information to distinguish the
   --  queries with the same name which are defined for both Record_Component
   --  and Array_Component.

end Asis.Data_Decomposition.Vcheck;

Add the ASIS file $i

Add the ASIS file $i


------------------------------------------------------------------------------
--                                                                          --
--                 ASIS-for-GNAT IMPLEMENTATION COMPONENTS                  --
--                                                                          --
--                             A 4 G . A _ S E M                            --
--                                                                          --
--                                 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 routines needed for semantic queries from
--  more than one Asis package

with Asis;         use Asis;

with A4G.Int_Knds; use A4G.Int_Knds;

with Einfo;        use Einfo;
with Types;        use Types;

package A4G.A_Sem is

   --  All the routines defined in this package do not check their
   --  arguments - a caller is responsible for the proper use of these
   --  routines

   ---------------------------------------
   -- Routines working on ASIS Elements --
   ---------------------------------------

   function Belongs_To_Limited_View (Decl : Asis.Element) return Boolean;
   --  Checks if the argument (declaration) Element may belong to a limited
   --  view of some package, see RM 05 10.1.1 (12.1/2 ..12.5/2))

   function Limited_View_Kind
     (Decl : Asis.Element)
      return Internal_Element_Kinds;
   --  Provided that Belongs_To_Limited_View (Decl), returns the rind that
   --  Decl should have in limited view (actually, the result is the kind of
   --  the argument except in case of type declarations, when the type is
   --  converted to An_Incomplete_Type_Declaration or
   --  A_Tagged_Incomplete_Type_Declaration

   function Get_Corr_Called_Entity
     (Call : Asis.Element)
      return Asis.Declaration;
   --  This function incapsulates the common code from
   --  Asis.Expressions.Corresponding_Called_Function and
   --  Asis.Statements.Corresponding_Called_Entity.
   --  It gets the Ada construction which is either a procedure (entry)
   --  or a function call and returns the declaration of the called
   --  entity. This function does not check this argument to be an
   --  appropriate Element for any of these ASIS queries.

   function Is_Range_Memberchip_Test (E : Asis.Element) return Boolean;
   function Is_Type_Memberchip_Test  (E : Asis.Element) return Boolean;
   --  These two functions are used as a check for appropriate Element in two
   --  obsolescent queries from Asis.Expressions - Membership_Test_Range and
   --  Membership_Test_Subtype_Mark respectively. They assume that an argument
   --  Element represents a membreship check Element. They check if the
   --  argument represents the membership test that in old ASIS was classified
   --  as An_In_Range_Membership_Test .. A_Not_In_Range_Membership_Test or
   --  An_In_Type_Membership_Test .. A_Not_In_Type_Membership_Test
   --  respectively.

   procedure Reset_For_Body
     (El        : in out Asis.Element;
      Body_Unit : Asis.Compilation_Unit);
   --  Provided that El is a declaration from the spec of a library package
   --  or a library generic package, this procedure resets El to Is_Identical
   --  Element, but obtained from the tree contained the body for this package.
   --  This body is represented by the Body_Unit parameter, we use it to avoid
   --  call to Asis.Compilation_Units.Corresponding_Body in the implementation
   --  of this function.

   ------------------------------------
   -- Routines working on tree nodes --
   ------------------------------------

   function Entity_Present (N : Node_Id) return Boolean;
   --  Differs from 'Present (Entity (N))' that in case if the check
   --  'Present (Entity (N))' does not point to an expression node as it
   --  happens for identifiers that identify aspects in aspect specifications.

   function Defined_In_Standard (N : Node_Id) return Boolean;
   --  checks if its argument is an identifier or an enumeration literal
   --  defined in the predefined Standard package

   function Char_Defined_In_Standard (N : Node_Id) return Boolean;
   --  Checks if its argument is a character literal defined in the
   --  predefined Standard package. Can be applied to reference nodes and
   --  entity nodes.

   function Unwind_Renaming (Def_Name : Node_Id) return Node_Id;
   --  Supposing that Def_Name is the node representing some defining
   --  occurrence of some name, this function unwinds all the renamings
   --  (if any) and returns the node representing the defining
   --  name of the entity referenced by this name. If there is no
   --  declaration for a given entity (this is the case, when a name
   --  renames a subprogram-attribute) an Empty node is returned.
   --
   --  Note, that the node for renaming declaration may be rewritten,
   --  in particular, renaming of a subprogram-attribute is rewritten
   --  into a subprogram body

   procedure Set_Stub_For_Subunit_If_Any (Def_Name : in out Node_Id);
   --  If Def_Name is N_Defining_Identifier node which represents the
   --  subprogram defining identifier from the proper body of a subunit,
   --  it is reset to point to the corresponding N_Defining_Identifier
   --  node from the corresponding body stub, if this stub acts as spec,
   --  or to the N_Defining_Identifier node from the corresponding
   --  subprogram declaration. Otherwise the argument remains unchanged.

   function Corr_Decl_For_Stub (Stub_Node : Node_Id) return Node_Id;
   --  This function should be called only for N_Subprogram_Body_Stub
   --  nodes. If the corresponding subprogram body stub is a completion
   --  of some subprogram declaration, the functions returns the node
   --  representing this subprogram declaration, otherwise it returns
   --  the Empty node.

   function Is_Anonymous (E : Entity_Kind) return Boolean;
   --  Check if E corresponds to an anonymous access type or subtype.

   function Is_Predefined (Def_Op : Node_Id) return Boolean;
   --  Returns True if Def_Op is N_Defining_Operator_Symbol representing
   --  a predefined operation. Returns False otherwise.
   --  ??? May be, there is something like this in GNAT???

   function Is_Impl_Neq (Def_Op : Entity_Id) return Boolean;
   --  Checks if the argument if the entity of implicit "/=" that is defined
   --  for explicit user-defined "="

   function Is_From_Instance (Node : Node_Id) return Boolean;
   --  Checks if Node is from expanded generic template

   function Is_From_Rewritten_Aggregate (Node : Node_Id) return Boolean;
   --  Checks if Node is an N_Component_Association node belonging to a
   --  rewritten tree structure corresponding to some aggregate. Returns False
   --  if Node is not of N_Component_Association kind.

   function Is_Name_Of_Expanded_Subprogram (Node : Node_Id) return Boolean;
   --  Detects if the argument is a defining name from an expanded subprogram
   --  instantiation, In this case the front-end creates an artificial
   --  defining identifier node that is not Comes_From_Source, but that also
   --  does not have an instantiation chain in Sloc, so ASIS can get confused
   --  with this node and treat is as an implicit node if apply the usual
   --  tests to it. (See G312-006).

   function Is_From_Unknown_Pragma (Node : Node_Id) return Boolean;
   --  Checks if Node belongs to a subtree rooted  by unknown pragma. The tree
   --  structures for unknown pragmas are very poorly decorated, so semantic
   --  queries may just blow up when applied to elements representing
   --  components of such pragmas.

   function Get_Actual_Type_Name (Type_Mark_Node : Node_Id) return Node_Id;
   --  This function supposes, that its argument is of N_Identifier kind.
   --  When applied to a reference to an implicit subtype created in
   --  expanded generic instantiation as a way to pass the actual type,
   --  this function "unwinds" this implicit subtyping and returns the
   --  reference to the actual type. Otherwise it returns its argument
   --  unchanged.
   --  The case when the actual type is a derived type is treated specially -
   --  in this case "unwinding" could bring the internal type created by the
   --  front-end, so we break this unwinding and return the entity (!!!) node
   --  of the corresponding actual type.

   function Get_Instance_Name (Int_Name : Node_Id) return Node_Id;
   --  For Int_Node which should be Is_Generic_Instance (otherwise it is an
   --  error to use this function) and which denotes the entity declared in
   --  an artificial package created by the compiler for a generic
   --  instantiation, it finds an entity defined in a generic instantiation

   function Get_Derived_Type
     (Type_Entity     : Entity_Id;
      Inherited_Subpr : Entity_Id)
      return            Entity_Id;
   --  This function supposes that Type_Entity is a type entity,
   --  and Inherited_Subpr is the defining name of implicit inherited
   --  subprogram. It checks if Type_Entity is an ancestor type for the
   --  derived type which inherits Inherited_Subpr, and if it is, returns
   --  the entity of the derived type, otherwise returns Type_Entity

   function Is_Derived_Rep_Item
     (Type_Entity : Entity_Id;
      Rep_Item :    Node_Id)
      return        Boolean;
   --  Supposing that Type_Entity is an entity of some type, and Rep_Item
   --  represents  some representation item from the chain of representation
   --  items associated with this type, this function checks it Type_Entity
   --  derives this Rep_Item from some of its parent types.

   function Is_Artificial_Protected_Op_Item_Spec
     (E :    Entity_Id)
      return Boolean;
   --  Checks if E represents the entity from the artificial subprogram spec
   --  created by the compiler for some protected_operation_item which does not
   --  have a separate spec in the source code.
   --  Note that this function check protected operation entity and entities of
   --  its formal parameters (At some point we should rename it as
   --  Is_FROM_Artificial_Protected_Op_Item_Spec)

   function Represents_Class_Wide_Type_In_Instance
     (N    : Node_Id)
      return Boolean;
   --  Test function used to check if from the ASIS viewpoint the argument may
   --  represent the 'Class attribute reference corresponding to the actual
   --  class-wide type in the instantiation (see F410-011 for full details)

   function Represents_Base_Type_In_Instance (N : Node_Id) return Boolean;
   --  Test function used to check if from the ASIS viewpoint the argument may
   --  represent the 'Base attribute reference corresponding to the actual
   --  type in the instantiation.

   function Pass_Generic_Actual (N : Node_Id) return Boolean;
   --  Checks if N represents an artificial (created by the front-end)
   --  declaration used to pass the actual in the instantiation. The problem
   --  here is that for such declarations the Sloc field not always (and not
   --  for all of their subcomponents) points to the instantiation chain.

   function Part_Of_Pass_Generic_Actual (N : Node_Id) return Boolean;
   --  This function checks if its argument is a subcomponent of the construct
   --  for that Pass_Generic_Actual returns True. The only reason to have these
   --  two function instead of just this one is performance.

   function Explicit_Parent_Subprogram (E : Entity_Id) return Entity_Id;
   --  Provided that E points to an inherited subprogram, this function
   --  computes the entity of the corresponding explicitly defined parent
   --  subprogram.

   function Get_Importing_Pragma (E : Entity_Id) return Node_Id;
   --  Supposing that E is an Is_Imported Entity node, compute the
   --  corresponding Import or Interface pragma.

   function Is_Applied_To
     (Pragma_Node : Node_Id;
      Entity_Node : Entity_Id)
      return        Boolean;
   --  Supposing that Pragma_Node denotes a pragma, and Entity_Node is an
   --  entity node (the caller is responsible for this), checks if the pragma
   --  is applied to the entity.

end A4G.A_Sem;

Add the ASIS file $i

Add the ASIS file $i


------------------------------------------------------------------------------
--                                                                          --
--                 ASIS-for-GNAT IMPLEMENTATION COMPONENTS                  --
--                                                                          --
--                          A 4 G . A _ T Y P E S                           --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--            Copyright (C) 1995-2010, 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).                                                --
--                                                                          --
------------------------------------------------------------------------------

with Ada.Unchecked_Conversion;

with System; use System;

with Hostparm;

package body A4G.A_Types is

   ---------------
   -- A_OS_Time --
   ---------------

   function A_OS_Time return ASIS_OS_Time is
   begin
      return ASIS_Clock;
   end A_OS_Time;

   -----------------------------
   -- Asis_Normalize_Pathname --
   -----------------------------

   Asis_Normalize_Pathname_Result : String_Access;

   function Asis_Normalize_Pathname
     (Name           : String;
      Directory      : String  := "";
      Resolve_Links  : Boolean := True;
      Case_Sensitive : Boolean := True) return String
   is
      --  ???
      --  All the stuff in the declarative part is copied from Osint...

      function C_String_Length (S : Address) return Integer;
      --  Returns length of a C string (zero for a null address)

      function To_Path_String_Access
        (Path_Addr : Address;
         Path_Len  : Integer) return String_Access;
      --  Converts a C String to an Ada String. Are we doing this to avoid
      --  withing Interfaces.C.Strings ???
      --  Caller must free result.

      function To_Host_Dir_Spec
        (Canonical_Dir : String;
         Prefix_Style  : Boolean) return String_Access;
      --  Convert a canonical syntax directory specification to host syntax.
      --  The Prefix_Style flag is currently ignored but should be set to
      --  False. Note that the caller must free result.
      --  ???
      --  Copied from Osint...

      function C_String_Length (S : Address) return Integer is
         function Strlen (S : Address) return Integer;
         pragma Import (C, Strlen, "strlen");
      begin
         if S = Null_Address then
            return 0;
         else
            return Strlen (S);
         end if;
      end C_String_Length;

      function To_Path_String_Access
        (Path_Addr : Address;
         Path_Len  : Integer) return String_Access
      is
         subtype Path_String is String (1 .. Path_Len);
         type Path_String_Access is access Path_String;

         function Address_To_Access is new
           Ada.Unchecked_Conversion (Source => Address,
                                     Target => Path_String_Access);

         Path_Access : constant Path_String_Access :=
                         Address_To_Access (Path_Addr);

         Return_Val : String_Access;

      begin
         Return_Val := new String (1 .. Path_Len);

         for J in 1 .. Path_Len loop
            Return_Val (J) := Path_Access (J);
         end loop;

         return Return_Val;
      end To_Path_String_Access;

      function To_Host_Dir_Spec
        (Canonical_Dir : String;
         Prefix_Style  : Boolean) return String_Access
      is
         function To_Host_Dir_Spec
           (Canonical_Dir : Address;
            Prefix_Flag   : Integer) return Address;
         pragma Import (C, To_Host_Dir_Spec, "__gnat_to_host_dir_spec");

         C_Canonical_Dir : String (1 .. Canonical_Dir'Length + 1);
         Host_Dir_Addr   : Address;
         Host_Dir_Len    : Integer;

      begin
         C_Canonical_Dir (1 .. Canonical_Dir'Length) := Canonical_Dir;
         C_Canonical_Dir (C_Canonical_Dir'Last)      := ASCII.NUL;

         if Prefix_Style then
            Host_Dir_Addr := To_Host_Dir_Spec (C_Canonical_Dir'Address, 1);
         else
            Host_Dir_Addr := To_Host_Dir_Spec (C_Canonical_Dir'Address, 0);
         end if;
         Host_Dir_Len := C_String_Length (Host_Dir_Addr);

         if Host_Dir_Len = 0 then
            return null;
         else
            return To_Path_String_Access (Host_Dir_Addr, Host_Dir_Len);
         end if;
      end To_Host_Dir_Spec;
   begin
      if Name = "" then
         return "";
      else
         Free (Asis_Normalize_Pathname_Result);

         Asis_Normalize_Pathname_Result := To_Host_Dir_Spec (
           Canonical_Dir =>
             Normalize_Pathname (
               Name           => Name,
               Directory      => Directory,
               Resolve_Links  => Resolve_Links,
               Case_Sensitive => Case_Sensitive),
           Prefix_Style  => False);

         return Asis_Normalize_Pathname_Result.all;
      end if;
   end Asis_Normalize_Pathname;

   ---------------------------
   -- Increase_ASIS_OS_Time --
   ---------------------------

   procedure Increase_ASIS_OS_Time is
   begin
      ASIS_Clock := ASIS_Clock + 1;
   end Increase_ASIS_OS_Time;

   -----------
   -- Later --
   -----------

   function Later (L, R : ASIS_OS_Time) return Boolean is
   begin
      return L <= R;
   end Later;

   ------------------------------
   -- Parameter_String_To_List --
   ------------------------------

   function Parameter_String_To_List
     (Par_String : String)
      return       Argument_List_Access
   is
      Max_Pars : constant Integer := Par_String'Length;
      New_Parv : Argument_List (1 .. Max_Pars);
      New_Parc : Natural := 0;
      Idx      : Integer;
      Old_Idx  : Integer;

      function Move_To_Next_Par (Ind : Integer) return Integer;
      --  Provided that Ind points somewhere inside Par_String, moves
      --  it ahead to point to the beginning of the next parameter if
      --  Ind points to the character considering as a parameter separator,
      --  otherwise returns Ind unchanged. If Ind points to a separator and
      --  there is no more parameters ahead, Par_String'Last + 1 is returned.
      --  (See the definition of the syntax of the Parameters string in the
      --  ASIS Reference Manual)

      function Move_To_Par_End (Ind : Integer) return Integer;
      --  Provided that Ind points to some character of a separate parameters
      --  being a part of Par_String, returns the index of the last character
      --  of this parameter

      function Move_To_Next_Par (Ind : Integer) return Integer is
         Result : Integer := Ind;
      begin

         while Result <=             Par_String'Last and then
              (Par_String (Result) = ' '      or else
               Par_String (Result) = ASCII.HT or else
               Par_String (Result) = ASCII.LF or else
               Par_String (Result) = ASCII.CR)
         loop
            Result := Result + 1;
         end loop;

         return Result;

      end Move_To_Next_Par;

      function Move_To_Par_End (Ind : Integer) return Integer is
         Result : Integer := Ind;
         Quoted : Boolean := False;
      begin

         loop

            --  Am unquoted white space or EOL is the end of an argument
            if not Quoted
              and then
              (Par_String (Result) = ' '      or else
               Par_String (Result) = ASCII.HT or else
               Par_String (Result) = ASCII.LF or else
               Par_String (Result) = ASCII.CR)
            then
               exit;

            --  Start of quoted string
            elsif not Quoted
              and then Par_String (Result) = '"'
            then
               Quoted := True;

            --  End of a quoted string and end of an argument
            elsif Quoted
              and then Par_String (Result) = '"'
            then
               Result := Result + 1;
               exit;
            end if;

            Result := Result + 1;
            exit when Result > Par_String'Last;
         end loop;

         Result := Result - 1;

         return Result;

      end Move_To_Par_End;

   begin
      Idx := Move_To_Next_Par (Par_String'First);

      while Idx <= Par_String'Last loop
         Old_Idx := Idx;
         Idx     := Move_To_Par_End (Idx);

         New_Parc := New_Parc + 1;
         New_Parv (New_Parc) :=
           new String'(Par_String (Old_Idx .. Idx));

         Idx := Move_To_Next_Par (Idx + 1);
      end loop;

      return new Argument_List'(New_Parv (1 .. New_Parc));
   end Parameter_String_To_List;

begin
   if Hostparm.OpenVMS then
      ASIS_Path_Separator    := ',';
      ASIS_Current_Directory := new String'("[]");
   else
      ASIS_Path_Separator    := GNAT.OS_Lib.Path_Separator;
      ASIS_Current_Directory := new String'(".");
   end if;
end A4G.A_Types;

Add the ASIS file $i

Add the ASIS file $i