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

--  The Security.OAuth.Clients package implements the client OAuth 2.0 authorization.
--
--  Note: OAuth 1.0 could be implemented but since it's being deprecated it's not worth doing it.
package Security.OAuth.Clients is

   --  ------------------------------
   --  Access Token
   --  ------------------------------
   --  Access tokens are credentials used to access protected resources.
   --  The access token is represented as a Principal.  This is an opaque
   --  value for an application.
   type Access_Token (Len : Natural) is new Security.Principal with private;
   type Access_Token_Access is access all Access_Token'Class;

   --  Get the principal name.  This is the OAuth access token.
   function Get_Name (From : in Access_Token) return String;

   type OpenID_Token (Len, Id_Len, Refresh_Len : Natural) is new Access_Token with private;
   type OpenID_Token_Access is access all OpenID_Token'Class;

   --  Get the id_token that was returned by the authentication process.
   function Get_Id_Token (From : in OpenID_Token) return String;

   --  Generate a random nonce with at last the number of random bits.
   --  The number of bits is rounded up to a multiple of 32.
   --  The random bits are then converted to base64url in the returned string.
   function Create_Nonce (Bits : in Positive := 256) return String;

   type Grant_Type is new Security.Principal with private;

   --  Get the principal name.  This is the OAuth access token.
   function Get_Name (From : in Grant_Type) return String;

   --  Get the Authorization header to be used for accessing a protected resource.
   --  (See RFC 6749 7.  Accessing Protected Resources)
   function Get_Authorization (From : in Grant_Type) return String;

   --  ------------------------------
   --  Application
   --  ------------------------------
   --  The Application holds the necessary information to let a user
   --  grant access to its protected resources on the resource server.  It contains
   --  information that allows the OAuth authorization server to identify the
   --  application (client id and secret key).
   type Application is new Security.OAuth.Application with private;

   --  Set the OAuth authorization server URI that the application must use
   --  to exchange the OAuth code into an access token.
   procedure Set_Provider_URI (App : in out Application;
                               URI : in String);

   --  OAuth 2.0 Section 4.1.1  Authorization Request

   --  Build a unique opaque value used to prevent cross-site request forgery.
   --  The Nonce parameters is an optional but recommended unique value
   --  used only once.  The state value will be returned back by the OAuth provider.
   --  This protects the <tt>client_id</tt> and <tt>redirect_uri</tt> parameters.
   function Get_State (App   : in Application;
                       Nonce : in String) return String;

   --  Get the authenticate parameters to build the URI to redirect the user to
   --  the OAuth authorization form.
   function Get_Auth_Params (App : in Application;
                             State : in String;
                             Scope : in String := "") return String;

   --  OAuth 2.0 Section 4.1.2  Authorization Response

   --  Verify that the State opaque value was created by the Get_State
   --  operation with the given client and redirect URL.
   function Is_Valid_State (App   : in Application;
                            Nonce : in String;
                            State : in String) return Boolean;

   --  OAuth 2.0 Section 4.1.3.  Access Token Request
   --            Section 4.1.4.  Access Token Response

   --  Exchange the OAuth code into an access token.
   function Request_Access_Token (App  : in Application;
                                  Code : in String) return Access_Token_Access;

   --  Get a request token with username and password.
   --  RFC 6749: 4.3.  Resource Owner Password Credentials Grant
   procedure Request_Token (App      : in Application;
                            Username : in String;
                            Password : in String;
                            Scope    : in String;
                            Token    : in out Grant_Type'Class);

   --  Create the access token
   function Create_Access_Token (App      : in Application;
                                 Token    : in String;
                                 Refresh  : in String;
                                 Id_Token : in String;
                                 Expires  : in Natural) return Access_Token_Access;

private

   type Access_Token (Len : Natural) is new Security.Principal with record
      Access_Id : String (1 .. Len);
   end record;

   type OpenID_Token (Len, Id_Len, Refresh_Len : Natural) is new Access_Token (Len) with record
      Id_Token      : String (1 .. Id_Len);
      Refresh_Token : String (1 .. Refresh_Len);
   end record;

   type Application is new Security.OAuth.Application with record
      Request_URI : Ada.Strings.Unbounded.Unbounded_String;
   end record;

   type Grant_Type is new Security.Principal with record
      Access_Token  : Ada.Strings.Unbounded.Unbounded_String;
      Refresh_Token : Ada.Strings.Unbounded.Unbounded_String;
      Id_Token      : Ada.Strings.Unbounded.Unbounded_String;
   end record;

end Security.OAuth.Clients;

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

--  The Security.OAuth.Clients package implements the client OAuth 2.0 authorization.
--
--  Note: OAuth 1.0 could be implemented but since it's being deprecated it's not worth doing it.
package Security.OAuth.Clients is

   --  ------------------------------
   --  Access Token
   --  ------------------------------
   --  Access tokens are credentials used to access protected resources.
   --  The access token is represented as a Principal.  This is an opaque
   --  value for an application.
   type Access_Token (Len : Natural) is new Security.Principal with private;
   type Access_Token_Access is access all Access_Token'Class;

   --  Get the principal name.  This is the OAuth access token.
   function Get_Name (From : in Access_Token) return String;

   type OpenID_Token (Len, Id_Len, Refresh_Len : Natural) is new Access_Token with private;
   type OpenID_Token_Access is access all OpenID_Token'Class;

   --  Get the id_token that was returned by the authentication process.
   function Get_Id_Token (From : in OpenID_Token) return String;

   --  Generate a random nonce with at last the number of random bits.
   --  The number of bits is rounded up to a multiple of 32.
   --  The random bits are then converted to base64url in the returned string.
   function Create_Nonce (Bits : in Positive := 256) return String;

   type Grant_Type is new Security.Principal with private;

   --  Get the principal name.  This is the OAuth access token.
   function Get_Name (From : in Grant_Type) return String;

   --  Get the Authorization header to be used for accessing a protected resource.
   --  (See RFC 6749 7.  Accessing Protected Resources)
   function Get_Authorization (From : in Grant_Type) return String;

   --  ------------------------------
   --  Application
   --  ------------------------------
   --  The Application holds the necessary information to let a user
   --  grant access to its protected resources on the resource server.  It contains
   --  information that allows the OAuth authorization server to identify the
   --  application (client id and secret key).
   type Application is new Security.OAuth.Application with private;

   --  Set the OAuth authorization server URI that the application must use
   --  to exchange the OAuth code into an access token.
   procedure Set_Provider_URI (App : in out Application;
                               URI : in String);

   --  OAuth 2.0 Section 4.1.1  Authorization Request

   --  Build a unique opaque value used to prevent cross-site request forgery.
   --  The Nonce parameters is an optional but recommended unique value
   --  used only once.  The state value will be returned back by the OAuth provider.
   --  This protects the <tt>client_id</tt> and <tt>redirect_uri</tt> parameters.
   function Get_State (App   : in Application;
                       Nonce : in String) return String;

   --  Get the authenticate parameters to build the URI to redirect the user to
   --  the OAuth authorization form.
   function Get_Auth_Params (App : in Application;
                             State : in String;
                             Scope : in String := "") return String;

   --  OAuth 2.0 Section 4.1.2  Authorization Response

   --  Verify that the State opaque value was created by the Get_State
   --  operation with the given client and redirect URL.
   function Is_Valid_State (App   : in Application;
                            Nonce : in String;
                            State : in String) return Boolean;

   --  OAuth 2.0 Section 4.1.3.  Access Token Request
   --            Section 4.1.4.  Access Token Response

   --  Exchange the OAuth code into an access token.
   function Request_Access_Token (App  : in Application;
                                  Code : in String) return Access_Token_Access;

   --  Get a request token with username and password.
   --  RFC 6749: 4.3.  Resource Owner Password Credentials Grant
   procedure Request_Token (App      : in Application;
                            Username : in String;
                            Password : in String;
                            Scope    : in String;
                            Token    : in out Grant_Type'Class);

   --  Refresh the access token.
   --  RFC 6749: 6.  Refreshing an Access Token
   procedure Refresh_Token (App      : in Application;
                            Scope    : in String;
                            Token    : in out Grant_Type'Class);

   --  Create the access token
   function Create_Access_Token (App      : in Application;
                                 Token    : in String;
                                 Refresh  : in String;
                                 Id_Token : in String;
                                 Expires  : in Natural) return Access_Token_Access;

private

   type Access_Token (Len : Natural) is new Security.Principal with record
      Access_Id : String (1 .. Len);
   end record;

   type OpenID_Token (Len, Id_Len, Refresh_Len : Natural) is new Access_Token (Len) with record
      Id_Token      : String (1 .. Id_Len);
      Refresh_Token : String (1 .. Refresh_Len);
   end record;

   type Application is new Security.OAuth.Application with record
      Request_URI : Ada.Strings.Unbounded.Unbounded_String;
   end record;

   type Grant_Type is new Security.Principal with record
      Access_Token  : Ada.Strings.Unbounded.Unbounded_String;
      Refresh_Token : Ada.Strings.Unbounded.Unbounded_String;
      Id_Token      : Ada.Strings.Unbounded.Unbounded_String;
   end record;

end Security.OAuth.Clients;

Declare the Refresh_Token procedure

Declare the Refresh_Token procedure


-----------------------------------------------------------------------
--  mat-consoles - Console interface
--  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.
-----------------------------------------------------------------------

package body MAT.Consoles is

   --  ------------------------------
   --  Print the title for the given field and setup the associated field size.
   --  ------------------------------
   procedure Print_Title (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Title   : in String;
                          Length  : in Positive) is
   begin
      Console.Sizes (Field) := Length;
      if Console.Field_Count >= 1 then
         Console.Cols (Field) := Console.Cols (Console.Fields (Console.Field_Count))
           + Console.Sizes (Console.Fields (Console.Field_Count));
      else
         Console.Cols (Field) := 1;
      end if;
      Console.Field_Count := Console.Field_Count + 1;
      Console.Fields (Console.Field_Count) := Field;
      Console_Type'Class (Console).Print_Title (Field, Title);
   end Print_Title;

   --  ------------------------------
   --  Format the address and print it for the given field.
   --  ------------------------------
   procedure Print_Field (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Addr    : in MAT.Types.Target_Addr) is
      Value : constant String := MAT.Types.Hex_Image (Addr);
   begin
      Console_Type'Class (Console).Print_Field (Field, Value);
   end Print_Field;

   --  ------------------------------
   --  Format the size and print it for the given field.
   --  ------------------------------
   procedure Print_Size (Console : in out Console_Type;
                         Field   : in Field_Type;
                         Size    : in MAT.Types.Target_Size) is
      Value : constant String := MAT.Types.Target_Size'Image (Size);
   begin
      Console_Type'Class (Console).Print_Field (Field, Value);
   end Print_Size;

   --  ------------------------------
   --  Format the thread information and print it for the given field.
   --  ------------------------------
   procedure Print_Thread (Console : in out Console_Type;
                           Field   : in Field_Type;
                           Thread  : in MAT.Types.Target_Thread_Ref) is
      Value : constant String := MAT.Types.Target_Thread_Ref'Image (Thread);
   begin
      Console_Type'Class (Console).Print_Field (Field, Value);
   end Print_Thread;

   --  ------------------------------
   --  Format the time tick as a duration and print it for the given field.
   --  ------------------------------
   procedure Print_Duration (Console  : in out Console_Type;
                             Field    : in Field_Type;
                             Duration : in MAT.Types.Target_Tick_Ref) is
      Value : constant String := MAT.Types.Tick_Image (Duration);
   begin
      Console_Type'Class (Console).Print_Field (Field, Value);
   end Print_Duration;

   --  ------------------------------
   --  Format the integer and print it for the given field.
   --  ------------------------------
   procedure Print_Field (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Value   : in Integer;
                          Justify : in Justify_Type := J_LEFT) is
      Val : constant String := Integer'Image (Value);
   begin
      Console_Type'Class (Console).Print_Field (Field, Val, Justify);
   end Print_Field;

   --  ------------------------------
   --  Format the integer and print it for the given field.
   --  ------------------------------
   procedure Print_Field (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Value   : in Ada.Strings.Unbounded.Unbounded_String;
                          Justify : in Justify_Type := J_LEFT) is
      Item : String := Ada.Strings.Unbounded.To_String (Value);
      Size : constant Natural := Console.Sizes (Field);
   begin
      if Size <= Item'Length then
         Item (Item'Last - Size + 2 .. Item'Last - Size + 4) := "...";
         Console_Type'Class (Console).Print_Field (Field, Item (Item'Last - Size + 2 .. Item'Last));
      else
         Console_Type'Class (Console).Print_Field (Field, Item, Justify);
      end if;
   end Print_Field;

end MAT.Consoles;

-----------------------------------------------------------------------
--  mat-consoles - Console interface
--  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.
-----------------------------------------------------------------------

package body MAT.Consoles is

   --  ------------------------------
   --  Print the title for the given field and setup the associated field size.
   --  ------------------------------
   procedure Print_Title (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Title   : in String;
                          Length  : in Positive) is
   begin
      Console.Sizes (Field) := Length;
      if Console.Field_Count >= 1 then
         Console.Cols (Field) := Console.Cols (Console.Fields (Console.Field_Count))
           + Console.Sizes (Console.Fields (Console.Field_Count));
      else
         Console.Cols (Field) := 1;
      end if;
      Console.Field_Count := Console.Field_Count + 1;
      Console.Fields (Console.Field_Count) := Field;
      Console_Type'Class (Console).Print_Title (Field, Title);
   end Print_Title;

   --  ------------------------------
   --  Format the address and print it for the given field.
   --  ------------------------------
   procedure Print_Field (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Addr    : in MAT.Types.Target_Addr) is
      Value : constant String := MAT.Types.Hex_Image (Addr);
   begin
      Console_Type'Class (Console).Print_Field (Field, Value);
   end Print_Field;

   --  ------------------------------
   --  Format the address range and print it for the given field.
   --  ------------------------------
   procedure Print_Field (Console : in out Console_Type;
                          Field   : in Field_Type;
                          From    : in MAT.Types.Target_Addr;
                          To      : in MAT.Types.Target_Addr) is
      From_Value : constant String := MAT.Types.Hex_Image (From);
      To_Value   : constant String := MAT.Types.Hex_Image (To);
   begin
      Console_Type'Class (Console).Print_Field (Field, From_Value & "-" & To_Value);
   end Print_Field;

   --  ------------------------------
   --  Format the size and print it for the given field.
   --  ------------------------------
   procedure Print_Size (Console : in out Console_Type;
                         Field   : in Field_Type;
                         Size    : in MAT.Types.Target_Size) is
      Value : constant String := MAT.Types.Target_Size'Image (Size);
   begin
      Console_Type'Class (Console).Print_Field (Field, Value);
   end Print_Size;

   --  ------------------------------
   --  Format the thread information and print it for the given field.
   --  ------------------------------
   procedure Print_Thread (Console : in out Console_Type;
                           Field   : in Field_Type;
                           Thread  : in MAT.Types.Target_Thread_Ref) is
      Value : constant String := MAT.Types.Target_Thread_Ref'Image (Thread);
   begin
      Console_Type'Class (Console).Print_Field (Field, Value);
   end Print_Thread;

   --  ------------------------------
   --  Format the time tick as a duration and print it for the given field.
   --  ------------------------------
   procedure Print_Duration (Console  : in out Console_Type;
                             Field    : in Field_Type;
                             Duration : in MAT.Types.Target_Tick_Ref) is
      Value : constant String := MAT.Types.Tick_Image (Duration);
   begin
      Console_Type'Class (Console).Print_Field (Field, Value);
   end Print_Duration;

   --  ------------------------------
   --  Format the integer and print it for the given field.
   --  ------------------------------
   procedure Print_Field (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Value   : in Integer;
                          Justify : in Justify_Type := J_LEFT) is
      Val : constant String := Integer'Image (Value);
   begin
      Console_Type'Class (Console).Print_Field (Field, Val, Justify);
   end Print_Field;

   --  ------------------------------
   --  Format the integer and print it for the given field.
   --  ------------------------------
   procedure Print_Field (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Value   : in Ada.Strings.Unbounded.Unbounded_String;
                          Justify : in Justify_Type := J_LEFT) is
      Item : String := Ada.Strings.Unbounded.To_String (Value);
      Size : constant Natural := Console.Sizes (Field);
   begin
      if Size <= Item'Length then
         Item (Item'Last - Size + 2 .. Item'Last - Size + 4) := "...";
         Console_Type'Class (Console).Print_Field (Field, Item (Item'Last - Size + 2 .. Item'Last));
      else
         Console_Type'Class (Console).Print_Field (Field, Item, Justify);
      end if;
   end Print_Field;

end MAT.Consoles;

Implement the Print_Field with a range of address


with Ada.Directories;
with Ada.Unchecked_Deallocation;

package body Native.Filesystem is

   --  ??? There are a bunch of 'Unrestricted_Access here because the
   --  HAL.Filesystem API embeds implicit references to filesystems. It
   --  woudl be good to make these references explicit at some point to
   --  avoid kludges.

   function "+" (S : Ada.Strings.Unbounded.Unbounded_String) return String
                 renames Ada.Strings.Unbounded.To_String;
   function "+" (S : String) return Ada.Strings.Unbounded.Unbounded_String
                 renames Ada.Strings.Unbounded.To_Unbounded_String;

   procedure Destroy is new Ada.Unchecked_Deallocation
     (Native_File_Handle, Native_File_Handle_Ref);
   procedure Destroy is new Ada.Unchecked_Deallocation
     (Native_Directory_Handle, Native_Directory_Handle_Ref);

   function "<" (Left, Right : Directory_Data_Entry) return Boolean is
     (Ada.Strings.Unbounded."<" (Left.Name, Right.Name));

   package Directory_Data_Sorting is
     new Directory_Data_Vectors.Generic_Sorting;

   --  Most of the time, standard operations give us no reliable way to
   --  determine specifically what triggered a failure, so use the following
   --  error code as a "generic" one.

   Generic_Error : constant Status_Kind := Input_Output_Error;

   function Absolute_Path
     (This          : Native_FS_Driver;
      Relative_Path : Pathname)
      return Pathname
   is (if Relative_Path = ""
       then +This.Root_Dir
       else Join (+This.Root_Dir, Relative_Path, True));

   ----------------
   -- Get_Handle --
   ----------------

   function Get_Handle
     (FS : in out Native_FS_Driver)
      return Native_File_Handle_Ref
   is
      Result : Native_File_Handle_Ref := FS.Free_File_Handles;
   begin
      if Result = null then
         Result := new Native_File_Handle'
           (FS     => FS'Unrestricted_Access,
            others => <>);
      else
         FS.Free_File_Handles := Result.Next;
      end if;
      return Result;
   end Get_Handle;

   ----------------
   -- Get_Handle --
   ----------------

   function Get_Handle
     (FS : in out Native_FS_Driver)
      return Native_Directory_Handle_Ref
   is
      Result : Native_Directory_Handle_Ref := FS.Free_Dir_Handles;
   begin
      if Result = null then
         Result := new Native_Directory_Handle'
           (FS     => FS'Unrestricted_Access,
            others => <>);
      else
         FS.Free_Dir_Handles := Result.Next;
      end if;
      return Result;
   end Get_Handle;

   ---------------------
   -- Add_Free_Handle --
   ---------------------

   procedure Add_Free_Handle
     (FS     : in out Native_FS_Driver;
      Handle : in out Native_File_Handle_Ref)
   is
   begin
      Handle.Next := FS.Free_File_Handles;
      FS.Free_File_Handles := Handle;
      Handle := null;
   end Add_Free_Handle;

   ---------------------
   -- Add_Free_Handle --
   ---------------------

   procedure Add_Free_Handle
     (FS     : in out Native_FS_Driver;
      Handle : in out Native_Directory_Handle_Ref)
   is
   begin
      Handle.Next := FS.Free_Dir_Handles;
      FS.Free_Dir_Handles := Handle;
      Handle := null;
   end Add_Free_Handle;

   -------------
   -- Destroy --
   -------------

   procedure Destroy (This : in out Native_FS_Driver_Ref) is
      procedure Destroy is new Ada.Unchecked_Deallocation
        (Native_FS_Driver, Native_FS_Driver_Ref);
   begin
      --  Free all handles

      while This.Free_File_Handles /= null loop
         declare
            H : constant Native_File_Handle_Ref := This.Free_File_Handles.Next;
         begin
            Destroy (This.Free_File_Handles);
            This.Free_File_Handles := H;
         end;
      end loop;
      while This.Free_Dir_Handles /= null loop
         declare
            H : constant Native_Directory_Handle_Ref :=
              This.Free_Dir_Handles.Next;
         begin
            Destroy (This.Free_Dir_Handles);
            This.Free_Dir_Handles := H;
         end;
      end loop;

      Destroy (This);
   end Destroy;

   ------------
   -- Create --
   ------------

   function Create
     (FS       : out Native_FS_Driver;
      Root_Dir : Pathname)
      return Status_Kind
   is
   begin
      declare
         use type Ada.Directories.File_Kind;
      begin
         if Ada.Directories.Kind (Root_Dir) /= Ada.Directories.Directory then
            return Invalid_Argument;
         end if;
      exception
         when Ada.Directories.Name_Error =>
            return Invalid_Argument;
      end;

      FS.Root_Dir := Ada.Strings.Unbounded.To_Unbounded_String (Root_Dir);
      return Status_Ok;
   end Create;

   -----------------
   -- Create_Node --
   -----------------

   overriding function Create_Node
     (This : in out Native_FS_Driver;
      Path : Pathname;
      Kind : File_Kind)
      return Status_Kind
   is
      Abs_Path : constant Pathname := Absolute_Path (This, Path);
   begin
      case Kind is
         when Regular_File =>
            declare
               File : Byte_IO.File_Type;
            begin
               begin
                  Byte_IO.Create (File, Byte_IO.Out_File, Abs_Path);
               exception
                  when Byte_IO.Status_Error
                     | Byte_IO.Name_Error
                     | Byte_IO.Use_Error
                     =>
                     return Generic_Error;
               end;
               Byte_IO.Close (File);
            end;

         when Directory =>
            begin
               Ada.Directories.Create_Directory (Abs_Path);
            exception
               when Ada.Directories.Name_Error
                  | Ada.Directories.Use_Error
                  =>
                  return Generic_Error;
            end;
      end case;

      return Status_Ok;
   end Create_Node;

   ----------------------
   -- Create_Directory --
   ----------------------

   overriding function Create_Directory
     (This : in out Native_FS_Driver;
      Path : Pathname)
      return Status_Kind
   is
   begin
      return This.Create_Node (Absolute_Path (This, Path), Directory);
   end Create_Directory;

   ------------
   -- Unlink --
   ------------

   overriding function Unlink
     (This : in out Native_FS_Driver;
      Path : Pathname)
      return Status_Kind
   is
   begin
      Ada.Directories.Delete_File (Absolute_Path (This, Path));
      return Status_Ok;
   exception
      when Ada.Directories.Name_Error
         | Ada.Directories.Use_Error
         =>
         return Generic_Error;
   end Unlink;

   ----------------------
   -- Remove_Directory --
   ----------------------

   overriding function Remove_Directory
     (This : in out Native_FS_Driver;
      Path : Pathname)
      return Status_Kind
   is
   begin
      Ada.Directories.Delete_Directory (Absolute_Path (This, Path));
      return Status_Ok;
   exception
      when Ada.Directories.Name_Error
         | Ada.Directories.Use_Error
         =>
         return Generic_Error;
   end Remove_Directory;

   ------------
   -- Rename --
   ------------

   overriding function Rename
     (This     : in out Native_FS_Driver;
      Old_Path : Pathname;
      New_Path : Pathname)
      return Status_Kind
   is
      Old_Abs_Path : constant Pathname := Absolute_Path (This, Old_Path);
      New_Abs_Path : constant Pathname := Absolute_Path (This, New_Path);
   begin
      Ada.Directories.Rename (Old_Abs_Path, New_Abs_Path);
      return Status_Ok;
   exception
      when Ada.Directories.Name_Error
         | Ada.Directories.Use_Error
         =>
         return Generic_Error;
   end Rename;

   -------------------
   -- Truncate_File --
   -------------------

   overriding function Truncate_File
     (This   : in out Native_FS_Driver;
      Path   : Pathname;
      Length : IO_Count)
      return Status_Kind
   is
      pragma Unreferenced (This, Path, Length);
   begin
      --  ??? Implement this. This is not done at the moment as there seems to
      --  be no other way using standard Ada packages than do delete the file
      --  and re-create it.

      return Generic_Error;
   end Truncate_File;

   ----------
   -- Open --
   ----------

   overriding function Open
     (This   : in out Native_FS_Driver;
      Path   : Pathname;
      Mode   : File_Mode;
      Handle : out File_Handle_Ref)
      return Status_Kind
   is
      Result : Native_File_Handle_Ref := This.Get_Handle;
   begin
      begin
         Byte_IO.Open
           (File => Result.File,
            Mode => (case Mode is
                     when Read_Only => Byte_IO.In_File,
                     when Write_Only => Byte_IO.Out_File,
                     when Read_Write => Byte_IO.Inout_File),
            Name => Absolute_Path (This, Path));
      exception
         when Byte_IO.Status_Error
            | Byte_IO.Name_Error
            | Byte_IO.Use_Error =>
            Destroy (Result);
            return Generic_Error;
      end;
      Handle := Result.all'Access;
      return Status_Ok;
   end Open;

   --------------------
   -- Open_Directory --
   --------------------

   overriding function Open_Directory
     (This   : in out Native_FS_Driver;
      Path   : Pathname;
      Handle : out Directory_Handle_Ref)
      return Status_Kind
   is
      use Ada.Strings.Unbounded;

      Result : Native_Directory_Handle_Ref := This.Get_Handle;
      Search : Ada.Directories.Search_Type;
   begin
      begin
         Ada.Directories.Start_Search (Search, Absolute_Path (This, Path), "");
      exception
         when Ada.Directories.Name_Error
            | Ada.Directories.Use_Error
            =>
            This.Add_Free_Handle (Result);
            return Generic_Error;
      end;

      Result.Full_Name := +Path;
      while Ada.Directories.More_Entries (Search) loop
         declare
            use type Ada.Directories.File_Kind;

            E    : Ada.Directories.Directory_Entry_Type;
            Kind : Ada.Directories.File_Kind;
            Name : Unbounded_String;
         begin
            Ada.Directories.Get_Next_Entry (Search, E);
            Kind := Ada.Directories.Kind (E);
            Name := +Ada.Directories.Simple_Name (E);

            --  HAL.Filesystem does not support special files, so just ignores
            --  them. As for current and parent directories entries, skip them
            --  for now as this makes tree traversal cumbersome to write.

            if Kind /= Ada.Directories.Special_File
              and then +Name /= "."
              and then +Name /= ".."
            then
               Result.Data.Append
                 ((Kind => (case Kind is
                            when Ada.Directories.Ordinary_File => Regular_File,
                            when Ada.Directories.Directory     => Directory,
                            when others => raise Program_Error),
                   Name => Name));
            end if;
         end;
      end loop;
      Ada.Directories.End_Search (Search);

      --  Make sure entries are sorted so that we get determinism. This is
      --  convenient for testing.

      Directory_Data_Sorting.Sort (Result.Data);

      Handle := Result.all'Access;
      return Status_Ok;
   end Open_Directory;

   ----------
   -- Read --
   ----------

   overriding function Read
     (This : in out Native_File_Handle;
      Data : out Byte_Array)
      return Status_Kind
   is
   begin
      for B of Data loop
         Byte_IO.Read (This.File, B);
      end loop;
      return Status_Ok;
   exception
      when Byte_IO.Mode_Error
         | Byte_IO.End_Error
         | Byte_IO.Data_Error
         =>
         return Generic_Error;
   end Read;

   -----------
   -- Write --
   -----------

   overriding function Write
     (This : in out Native_File_Handle;
      Data : Byte_Array)
      return Status_Kind
   is
   begin
      for B of Data loop
         Byte_IO.Write (This.File, B);
      end loop;
      return Status_Ok;
   exception
      when Byte_IO.Mode_Error
         | Byte_IO.Use_Error
         =>
         return Generic_Error;
   end Write;

   ----------
   -- Seek --
   ----------

   overriding function Seek
     (This   : in out Native_File_Handle;
      Offset : IO_Count)
      return Status_Kind
   is
   begin
      Byte_IO.Set_Index (This.File, Byte_IO.Positive_Count (Offset));
      return Status_Ok;
   end Seek;

   -----------
   -- Close --
   -----------

   overriding function Close
     (This : in out Native_File_Handle)
      return Status_Kind
   is
      This_Ref : Native_File_Handle_Ref := This'Unrestricted_Access;
   begin
      begin
         Byte_IO.Close (This.File);
      exception
         when Byte_IO.Status_Error =>
            return Generic_Error;
      end;

      This_Ref.FS.Add_Free_Handle (This_Ref);
      return Status_Ok;
   end Close;

   ----------------
   -- Read_Entry --
   ----------------

   overriding function Read_Entry
     (This         : in out Native_Directory_Handle;
      Entry_Number : Positive;
      Dir_Entry    : out Directory_Entry)
      return Status_Kind
   is
   begin
      if Entry_Number > This.Data.Last_Index then
         return No_Such_File_Or_Directory;
      end if;

      Dir_Entry := (Entry_Type => This.Data.Element (Entry_Number).Kind);
      return Status_Ok;
   end Read_Entry;

   ----------------
   -- Entry_Name --
   ----------------

   overriding function Entry_Name
     (This         : in out Native_Directory_Handle;
      Entry_Number : Positive)
      return Pathname
   is
   begin
      if Entry_Number > This.Data.Last_Index then
         return "";
      end if;

      return +This.Data.Element (Entry_Number).Name;
   end Entry_Name;

   -----------
   -- Close --
   -----------

   overriding function Close
     (This : in out Native_Directory_Handle)
      return Status_Kind
   is
      This_Ref : Native_Directory_Handle_Ref := This'Unrestricted_Access;
   begin
      This.Data.Clear;
      This_Ref.FS.Add_Free_Handle (This_Ref);
      return Status_Ok;
   end Close;

   ----------
   -- Join --
   ----------

   function Join
     (Prefix, Suffix           : Pathname;
      Ignore_Absolute_Suffixes : Boolean)
      return Pathname
   is
      use Ada.Strings.Unbounded;

      package String_Vectors is new Ada.Containers.Vectors
        (Positive, Unbounded_String);

      Result : Unbounded_String := +Prefix;
      Names  : String_Vectors.Vector;

   begin
      --  First, decompose Suffix into individual names: the following pushes
      --  the most local directory names first, then the most global ones. For
      --  instance, "a/b/c" will gives: Name => ("c", "b", "a").

      declare
         Suffix_Acc : Unbounded_String := +Suffix;
      begin
         while Length (Suffix_Acc) > 0 loop
            begin
               declare
                  Suffix      : constant String := +Suffix_Acc;
                  Next_Suffix : constant String :=
                    Ada.Directories.Containing_Directory (Suffix);
                  Name        : constant String :=
                    Ada.Directories.Simple_Name (Suffix);
               begin
                  --  The following happens when Suffix is "." (the current
                  --  directory).

                  exit when Suffix = Next_Suffix;
                  Names.Append (+Name);
                  Suffix_Acc := +Next_Suffix;
               end;

            exception
               when Ada.Directories.Use_Error =>

                  --  Suffix is actually an absolute path. Forget about it and
                  --  process it as a relative one.

                  exit when Ignore_Absolute_Suffixes;
                  return Suffix;
            end;
         end loop;
      end;

      --  Then, compose them using Ada.Directories.Compose so we have our
      --  result.

      for Name of reverse Names loop
         Result := +Ada.Directories.Compose (+Result, +Name);
      end loop;
      return +Result;
   end Join;

end Native.Filesystem;

with Ada.Directories;
with Ada.Unchecked_Deallocation;

package body Native.Filesystem is

   --  ??? There are a bunch of 'Unrestricted_Access here because the
   --  HAL.Filesystem API embeds implicit references to filesystems. It
   --  woudl be good to make these references explicit at some point to
   --  avoid kludges.

   function "+" (S : Ada.Strings.Unbounded.Unbounded_String) return String
                 renames Ada.Strings.Unbounded.To_String;
   function "+" (S : String) return Ada.Strings.Unbounded.Unbounded_String
                 renames Ada.Strings.Unbounded.To_Unbounded_String;

   procedure Destroy is new Ada.Unchecked_Deallocation
     (Native_File_Handle, Native_File_Handle_Ref);
   procedure Destroy is new Ada.Unchecked_Deallocation
     (Native_Directory_Handle, Native_Directory_Handle_Ref);

   function "<" (Left, Right : Directory_Data_Entry) return Boolean is
     (Ada.Strings.Unbounded."<" (Left.Name, Right.Name));

   package Directory_Data_Sorting is
     new Directory_Data_Vectors.Generic_Sorting;

   --  Most of the time, standard operations give us no reliable way to
   --  determine specifically what triggered a failure, so use the following
   --  error code as a "generic" one.

   Generic_Error : constant Status_Kind := Input_Output_Error;

   function Absolute_Path
     (This          : Native_FS_Driver;
      Relative_Path : Pathname)
      return Pathname
   is (if Relative_Path = ""
       then +This.Root_Dir
       else Join (+This.Root_Dir, Relative_Path, True));

   ----------------
   -- Get_Handle --
   ----------------

   function Get_Handle
     (FS : in out Native_FS_Driver)
      return Native_File_Handle_Ref
   is
      Result : Native_File_Handle_Ref := FS.Free_File_Handles;
   begin
      if Result = null then
         Result := new Native_File_Handle'
           (FS     => FS'Unrestricted_Access,
            others => <>);
      else
         FS.Free_File_Handles := Result.Next;
      end if;
      return Result;
   end Get_Handle;

   ----------------
   -- Get_Handle --
   ----------------

   function Get_Handle
     (FS : in out Native_FS_Driver)
      return Native_Directory_Handle_Ref
   is
      Result : Native_Directory_Handle_Ref := FS.Free_Dir_Handles;
   begin
      if Result = null then
         Result := new Native_Directory_Handle'
           (FS     => FS'Unrestricted_Access,
            others => <>);
      else
         FS.Free_Dir_Handles := Result.Next;
      end if;
      return Result;
   end Get_Handle;

   ---------------------
   -- Add_Free_Handle --
   ---------------------

   procedure Add_Free_Handle
     (FS     : in out Native_FS_Driver;
      Handle : in out Native_File_Handle_Ref)
   is
   begin
      Handle.Next := FS.Free_File_Handles;
      FS.Free_File_Handles := Handle;
      Handle := null;
   end Add_Free_Handle;

   ---------------------
   -- Add_Free_Handle --
   ---------------------

   procedure Add_Free_Handle
     (FS     : in out Native_FS_Driver;
      Handle : in out Native_Directory_Handle_Ref)
   is
   begin
      Handle.Next := FS.Free_Dir_Handles;
      FS.Free_Dir_Handles := Handle;
      Handle := null;
   end Add_Free_Handle;

   -------------
   -- Destroy --
   -------------

   procedure Destroy (This : in out Native_FS_Driver_Ref) is
      procedure Destroy is new Ada.Unchecked_Deallocation
        (Native_FS_Driver, Native_FS_Driver_Ref);
   begin
      --  Free all handles

      while This.Free_File_Handles /= null loop
         declare
            H : constant Native_File_Handle_Ref := This.Free_File_Handles.Next;
         begin
            Destroy (This.Free_File_Handles);
            This.Free_File_Handles := H;
         end;
      end loop;
      while This.Free_Dir_Handles /= null loop
         declare
            H : constant Native_Directory_Handle_Ref :=
              This.Free_Dir_Handles.Next;
         begin
            Destroy (This.Free_Dir_Handles);
            This.Free_Dir_Handles := H;
         end;
      end loop;

      Destroy (This);
   end Destroy;

   ------------
   -- Create --
   ------------

   function Create
     (FS       : out Native_FS_Driver;
      Root_Dir : Pathname)
      return Status_Kind
   is
   begin
      declare
         use type Ada.Directories.File_Kind;
      begin
         if Ada.Directories.Kind (Root_Dir) /= Ada.Directories.Directory then
            return Invalid_Argument;
         end if;
      exception
         when Ada.Directories.Name_Error =>
            return Invalid_Argument;
      end;

      FS.Root_Dir := Ada.Strings.Unbounded.To_Unbounded_String (Root_Dir);
      return Status_Ok;
   end Create;

   -----------------
   -- Create_Node --
   -----------------

   overriding function Create_Node
     (This : in out Native_FS_Driver;
      Path : Pathname;
      Kind : File_Kind)
      return Status_Kind
   is
      Abs_Path : constant Pathname := Absolute_Path (This, Path);
   begin
      case Kind is
         when Regular_File =>
            declare
               File : Byte_IO.File_Type;
            begin
               begin
                  Byte_IO.Create (File, Byte_IO.Out_File, Abs_Path);
               exception
                  when Byte_IO.Status_Error
                     | Byte_IO.Name_Error
                     | Byte_IO.Use_Error
                     =>
                     return Generic_Error;
               end;
               Byte_IO.Close (File);
            end;

         when Directory =>
            begin
               Ada.Directories.Create_Directory (Abs_Path);
            exception
               when Ada.Directories.Name_Error
                  | Ada.Directories.Use_Error
                  =>
                  return Generic_Error;
            end;
      end case;

      return Status_Ok;
   end Create_Node;

   ----------------------
   -- Create_Directory --
   ----------------------

   overriding function Create_Directory
     (This : in out Native_FS_Driver;
      Path : Pathname)
      return Status_Kind
   is
   begin
      return This.Create_Node (Absolute_Path (This, Path), Directory);
   end Create_Directory;

   ------------
   -- Unlink --
   ------------

   overriding function Unlink
     (This : in out Native_FS_Driver;
      Path : Pathname)
      return Status_Kind
   is
   begin
      Ada.Directories.Delete_File (Absolute_Path (This, Path));
      return Status_Ok;
   exception
      when Ada.Directories.Name_Error
         | Ada.Directories.Use_Error
         =>
         return Generic_Error;
   end Unlink;

   ----------------------
   -- Remove_Directory --
   ----------------------

   overriding function Remove_Directory
     (This : in out Native_FS_Driver;
      Path : Pathname)
      return Status_Kind
   is
   begin
      Ada.Directories.Delete_Directory (Absolute_Path (This, Path));
      return Status_Ok;
   exception
      when Ada.Directories.Name_Error
         | Ada.Directories.Use_Error
         =>
         return Generic_Error;
   end Remove_Directory;

   ------------
   -- Rename --
   ------------

   overriding function Rename
     (This     : in out Native_FS_Driver;
      Old_Path : Pathname;
      New_Path : Pathname)
      return Status_Kind
   is
      Old_Abs_Path : constant Pathname := Absolute_Path (This, Old_Path);
      New_Abs_Path : constant Pathname := Absolute_Path (This, New_Path);
   begin
      Ada.Directories.Rename (Old_Abs_Path, New_Abs_Path);
      return Status_Ok;
   exception
      when Ada.Directories.Name_Error
         | Ada.Directories.Use_Error
         =>
         return Generic_Error;
   end Rename;

   -------------------
   -- Truncate_File --
   -------------------

   overriding function Truncate_File
     (This   : in out Native_FS_Driver;
      Path   : Pathname;
      Length : IO_Count)
      return Status_Kind
   is
      pragma Unreferenced (This, Path, Length);
   begin
      --  ??? Implement this. This is not done at the moment as there seems to
      --  be no other way using standard Ada packages than do delete the file
      --  and re-create it.

      return Generic_Error;
   end Truncate_File;

   ----------
   -- Open --
   ----------

   overriding function Open
     (This   : in out Native_FS_Driver;
      Path   : Pathname;
      Mode   : File_Mode;
      Handle : out File_Handle_Ref)
      return Status_Kind
   is
      Result : Native_File_Handle_Ref := This.Get_Handle;
   begin
      begin
         Byte_IO.Open
           (File => Result.File,
            Mode => (case Mode is
                     when Read_Only => Byte_IO.In_File,
                     when Write_Only => Byte_IO.Out_File,
                     when Read_Write => Byte_IO.Inout_File),
            Name => Absolute_Path (This, Path));
      exception
         when Byte_IO.Status_Error
            | Byte_IO.Name_Error
            | Byte_IO.Use_Error =>
            Destroy (Result);
            return Generic_Error;
      end;
      Handle := Result.all'Access;
      return Status_Ok;
   end Open;

   --------------------
   -- Open_Directory --
   --------------------

   overriding function Open_Directory
     (This   : in out Native_FS_Driver;
      Path   : Pathname;
      Handle : out Directory_Handle_Ref)
      return Status_Kind
   is
      use Ada.Strings.Unbounded;

      Result : Native_Directory_Handle_Ref := This.Get_Handle;
      Search : Ada.Directories.Search_Type;
   begin
      begin
         Ada.Directories.Start_Search (Search, Absolute_Path (This, Path), "");
      exception
         when Ada.Directories.Name_Error
            | Ada.Directories.Use_Error
            =>
            This.Add_Free_Handle (Result);
            return Generic_Error;
      end;

      Result.Full_Name := +Path;
      while Ada.Directories.More_Entries (Search) loop
         declare
            use type Ada.Directories.File_Kind;

            E    : Ada.Directories.Directory_Entry_Type;
            Kind : Ada.Directories.File_Kind;
            Name : Unbounded_String;
         begin
            Ada.Directories.Get_Next_Entry (Search, E);
            Kind := Ada.Directories.Kind (E);
            Name := +Ada.Directories.Simple_Name (E);

            --  HAL.Filesystem does not support special files, so just ignores
            --  them. As for current and parent directories entries, skip them
            --  for now as this makes tree traversal cumbersome to write.

            if Kind /= Ada.Directories.Special_File
              and then +Name /= "."
              and then +Name /= ".."
            then
               Result.Data.Append
                 ((Kind => (case Kind is
                            when Ada.Directories.Ordinary_File => Regular_File,
                            when Ada.Directories.Directory     => Directory,
                            when others => raise Program_Error),
                   Name => Name));
            end if;
         end;
      end loop;
      Ada.Directories.End_Search (Search);

      --  Make sure entries are sorted so that we get determinism. This is
      --  convenient for testing.

      Directory_Data_Sorting.Sort (Result.Data);

      Handle := Result.all'Access;
      return Status_Ok;
   end Open_Directory;

   ----------
   -- Read --
   ----------

   overriding function Read
     (This : in out Native_File_Handle;
      Data : out Byte_Array)
      return Status_Kind
   is
   begin
      for B of Data loop
         Byte_IO.Read (This.File, B);
      end loop;
      return Status_Ok;
   exception
      when Byte_IO.Mode_Error
         | Byte_IO.End_Error
         | Byte_IO.Data_Error
         =>
         return Generic_Error;
   end Read;

   -----------
   -- Write --
   -----------

   overriding function Write
     (This : in out Native_File_Handle;
      Data : Byte_Array)
      return Status_Kind
   is
   begin
      for B of Data loop
         Byte_IO.Write (This.File, B);
      end loop;
      return Status_Ok;
   exception
      when Byte_IO.Mode_Error
         | Byte_IO.Use_Error
         =>
         return Generic_Error;
   end Write;

   ----------
   -- Seek --
   ----------

   overriding function Seek
     (This   : in out Native_File_Handle;
      Offset : IO_Count)
      return Status_Kind
   is
   begin
      Byte_IO.Set_Index (This.File, Byte_IO.Positive_Count (Offset + 1));
      return Status_Ok;
   end Seek;

   -----------
   -- Close --
   -----------

   overriding function Close
     (This : in out Native_File_Handle)
      return Status_Kind
   is
      This_Ref : Native_File_Handle_Ref := This'Unrestricted_Access;
   begin
      begin
         Byte_IO.Close (This.File);
      exception
         when Byte_IO.Status_Error =>
            return Generic_Error;
      end;

      This_Ref.FS.Add_Free_Handle (This_Ref);
      return Status_Ok;
   end Close;

   ----------------
   -- Read_Entry --
   ----------------

   overriding function Read_Entry
     (This         : in out Native_Directory_Handle;
      Entry_Number : Positive;
      Dir_Entry    : out Directory_Entry)
      return Status_Kind
   is
   begin
      if Entry_Number > This.Data.Last_Index then
         return No_Such_File_Or_Directory;
      end if;

      Dir_Entry := (Entry_Type => This.Data.Element (Entry_Number).Kind);
      return Status_Ok;
   end Read_Entry;

   ----------------
   -- Entry_Name --
   ----------------

   overriding function Entry_Name
     (This         : in out Native_Directory_Handle;
      Entry_Number : Positive)
      return Pathname
   is
   begin
      if Entry_Number > This.Data.Last_Index then
         return "";
      end if;

      return +This.Data.Element (Entry_Number).Name;
   end Entry_Name;

   -----------
   -- Close --
   -----------

   overriding function Close
     (This : in out Native_Directory_Handle)
      return Status_Kind
   is
      This_Ref : Native_Directory_Handle_Ref := This'Unrestricted_Access;
   begin
      This.Data.Clear;
      This_Ref.FS.Add_Free_Handle (This_Ref);
      return Status_Ok;
   end Close;

   ----------
   -- Join --
   ----------

   function Join
     (Prefix, Suffix           : Pathname;
      Ignore_Absolute_Suffixes : Boolean)
      return Pathname
   is
      use Ada.Strings.Unbounded;

      package String_Vectors is new Ada.Containers.Vectors
        (Positive, Unbounded_String);

      Result : Unbounded_String := +Prefix;
      Names  : String_Vectors.Vector;

   begin
      --  First, decompose Suffix into individual names: the following pushes
      --  the most local directory names first, then the most global ones. For
      --  instance, "a/b/c" will gives: Name => ("c", "b", "a").

      declare
         Suffix_Acc : Unbounded_String := +Suffix;
      begin
         while Length (Suffix_Acc) > 0 loop
            begin
               declare
                  Suffix      : constant String := +Suffix_Acc;
                  Next_Suffix : constant String :=
                    Ada.Directories.Containing_Directory (Suffix);
                  Name        : constant String :=
                    Ada.Directories.Simple_Name (Suffix);
               begin
                  --  The following happens when Suffix is "." (the current
                  --  directory).

                  exit when Suffix = Next_Suffix;
                  Names.Append (+Name);
                  Suffix_Acc := +Next_Suffix;
               end;

            exception
               when Ada.Directories.Use_Error =>

                  --  Suffix is actually an absolute path. Forget about it and
                  --  process it as a relative one.

                  exit when Ignore_Absolute_Suffixes;
                  return Suffix;
            end;
         end loop;
      end;

      --  Then, compose them using Ada.Directories.Compose so we have our
      --  result.

      for Name of reverse Names loop
         Result := +Ada.Directories.Compose (+Result, +Name);
      end loop;
      return +Result;
   end Join;

end Native.Filesystem;

Fix Seek()

Native.Filesystem: Fix Seek()

Byte_IO.Set_Index starts at 1 where HAL.Filesystem starts at 0.


-----------------------------------------------------------------------
--  awa-workspaces-module -- Module workspaces
--  Copyright (C) 2011, 2012, 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 ADO.Sessions;

with ASF.Applications;

with AWA.Modules;
with AWA.Services.Contexts;
with AWA.Workspaces.Models;
with AWA.Users.Services;
with AWA.Users.Models;
with AWA.Events;
package AWA.Workspaces.Modules is

   Not_Found : exception;

   --  The name under which the module is registered.
   NAME : constant String := "workspaces";

   package Invite_User_Event is new AWA.Events.Definition (Name => "invite-user");

   --  ------------------------------
   --  Module workspaces
   --  ------------------------------
   type Workspace_Module is new AWA.Modules.Module with private;
   type Workspace_Module_Access is access all Workspace_Module'Class;

   --  Initialize the workspaces module.
   overriding
   procedure Initialize (Plugin : in out Workspace_Module;
                         App    : in AWA.Modules.Application_Access;
                         Props  : in ASF.Applications.Config);

   --  Get the current workspace associated with the current user.
   --  If the user has not workspace, create one.
   procedure Get_Workspace (Session   : in out ADO.Sessions.Master_Session;
                            Context   : in AWA.Services.Contexts.Service_Context_Access;
                            Workspace : out AWA.Workspaces.Models.Workspace_Ref);

   --  Load the invitation from the access key and verify that the key is still valid.
   procedure Load_Invitation (Module     : in Workspace_Module;
                              Key        : in String;
                              Invitation : in out AWA.Workspaces.Models.Invitation_Ref'Class;
                              Inviter    : in out AWA.Users.Models.User_Ref);

   --  Accept the invitation identified by the access key.
   procedure Accept_Invitation (Module     : in Workspace_Module;
                                Key        : in String);

   --  Send the invitation to the user.
   procedure Send_Invitation (Module : in Workspace_Module;
                              Invitation : in out AWA.Workspaces.Models.Invitation_Ref'Class);

   --  Delete the member from the workspace.  Remove the invitation if there is one.
   procedure Delete_Member (Module       : in Workspace_Module;
                            User_Id      : in ADO.Identifier;
                            Workspace_Id : in ADO.Identifier);

private

   type Workspace_Module is new AWA.Modules.Module with record
      User_Manager : AWA.Users.Services.User_Service_Access;
   end record;

end AWA.Workspaces.Modules;

-----------------------------------------------------------------------
--  awa-workspaces-module -- Module workspaces
--  Copyright (C) 2011, 2012, 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 ADO.Sessions;

with ASF.Applications;

with AWA.Modules;
with AWA.Services.Contexts;
with AWA.Workspaces.Models;
with AWA.Users.Services;
with AWA.Users.Models;
with AWA.Events;
package AWA.Workspaces.Modules is

   Not_Found : exception;

   --  The name under which the module is registered.
   NAME : constant String := "workspaces";

   package Invite_User_Event is new AWA.Events.Definition (Name => "invite-user");

   --  ------------------------------
   --  Module workspaces
   --  ------------------------------
   type Workspace_Module is new AWA.Modules.Module with private;
   type Workspace_Module_Access is access all Workspace_Module'Class;

   --  Initialize the workspaces module.
   overriding
   procedure Initialize (Plugin : in out Workspace_Module;
                         App    : in AWA.Modules.Application_Access;
                         Props  : in ASF.Applications.Config);

   --  Get the current workspace associated with the current user.
   --  If the user has not workspace, create one.
   procedure Get_Workspace (Session   : in out ADO.Sessions.Master_Session;
                            Context   : in AWA.Services.Contexts.Service_Context_Access;
                            Workspace : out AWA.Workspaces.Models.Workspace_Ref);

   --  Load the invitation from the access key and verify that the key is still valid.
   procedure Load_Invitation (Module     : in Workspace_Module;
                              Key        : in String;
                              Invitation : in out AWA.Workspaces.Models.Invitation_Ref'Class;
                              Inviter    : in out AWA.Users.Models.User_Ref);

   --  Accept the invitation identified by the access key.
   procedure Accept_Invitation (Module     : in Workspace_Module;
                                Key        : in String);

   --  Send the invitation to the user.
   procedure Send_Invitation (Module : in Workspace_Module;
                              Invitation : in out AWA.Workspaces.Models.Invitation_Ref'Class);

   --  Delete the member from the workspace.  Remove the invitation if there is one.
   procedure Delete_Member (Module       : in Workspace_Module;
                            Member_Id    : in ADO.Identifier);

private

   type Workspace_Module is new AWA.Modules.Module with record
      User_Manager : AWA.Users.Services.User_Service_Access;
   end record;

end AWA.Workspaces.Modules;

Change Delete_Member to use the member id


-----------------------------------------------------------------------
--  druss-commands -- Commands available for Druss
--  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.Commands.Drivers;
with Util.Commands.Consoles;
with Util.Commands.Consoles.Text;
with Druss.Gateways;
package Druss.Commands is

   --  The list of fields that are printed on the console.
   type Field_Type is (F_IP_ADDR,
                       F_BBOX_IP_ADDR,
                       F_WAN_IP,
                       F_ETHERNET,
                       F_INTERNET,
                       F_VOIP,
                       F_HOSTNAME,
                       F_CONNECTION,
                       F_DEVTYPE,
                       F_ACTIVE,
                       F_LINK,
                       F_WIFI,
                       F_WIFI5,
                       F_ACCESS_CONTROL,
                       F_DYNDNS,
                       F_DEVICES,
                       F_UPTIME,
                       F_COUNT,
                       F_BOOL,
                       F_CHANNEL,
                       F_PROTOCOL,
                       F_ENCRYPTION,
                       F_SSID);

   --  The type of notice that are reported.
   type Notice_Type is (N_HELP,
                        N_USAGE,
                        N_INFO);

   --  Make the generic abstract console interface.
   package Consoles is
     new Util.Commands.Consoles (Field_Type  => Field_Type,
                                 Notice_Type => Notice_Type);

   --  And the text console to write on stdout (a Gtk console could be done someday).
   package Text_Consoles is
      new Consoles.Text;

   type Context_Type is limited record
      Gateways : Druss.Gateways.Gateway_Vector;
      Console  : Consoles.Console_Access;
   end record;

   package Drivers is
     new Util.Commands.Drivers (Context_Type => Context_Type,
                                Driver_Name  => "druss-drivers");

   subtype Argument_List is Util.Commands.Argument_List;

   Driver : Drivers.Driver_Type;

   procedure Gateway_Command (Command   : in Drivers.Command_Type'Class;
                              Args      : in Util.Commands.Argument_List'Class;
                              Arg_Pos   : in Positive;
                              Process   : access procedure (Gateway : in out Gateways.Gateway_Type;
                                                            Param   : in String);
                              Context   : in out Context_Type);

   procedure Initialize;

   --  Print the bbox API status.
   procedure Print_Status (Console : in Consoles.Console_Access;
                           Field   : in Field_Type;
                           Value   : in String);

   --  Print a ON/OFF status.
   procedure Print_On_Off (Console : in Consoles.Console_Access;
                           Field   : in Field_Type;
                           Value   : in String);

   --  Print a uptime.
   procedure Print_Uptime (Console : in Consoles.Console_Access;
                           Field   : in Field_Type;
                           Value   : in String);

end Druss.Commands;

-----------------------------------------------------------------------
--  druss-commands -- Commands available for Druss
--  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.Commands.Drivers;
with Util.Commands.Consoles;
with Util.Commands.Consoles.Text;
with Druss.Gateways;
package Druss.Commands is

   --  The list of fields that are printed on the console.
   type Field_Type is (F_IP_ADDR,
                       F_BBOX_IP_ADDR,
                       F_WAN_IP,
                       F_ETHERNET,
                       F_INTERNET,
                       F_VOIP,
                       F_HOSTNAME,
                       F_CONNECTION,
                       F_DEVTYPE,
                       F_ACTIVE,
                       F_LINK,
                       F_WIFI,
                       F_WIFI5,
                       F_ACCESS_CONTROL,
                       F_DYNDNS,
                       F_DEVICES,
                       F_UPTIME,
                       F_COUNT,
                       F_BOOL,
                       F_CHANNEL,
                       F_PROTOCOL,
                       F_ENCRYPTION,
                       F_SSID);

   --  The type of notice that are reported.
   type Notice_Type is (N_HELP,
                        N_USAGE,
                        N_INFO);

   --  Make the generic abstract console interface.
   package Consoles is
     new Util.Commands.Consoles (Field_Type  => Field_Type,
                                 Notice_Type => Notice_Type);

   --  And the text console to write on stdout (a Gtk console could be done someday).
   package Text_Consoles is
      new Consoles.Text;

   type Context_Type is limited record
      Gateways : Druss.Gateways.Gateway_Vector;
      Console  : Consoles.Console_Access;
   end record;

   package Drivers is
     new Util.Commands.Drivers (Context_Type => Context_Type,
                                Driver_Name  => "druss-drivers");

   subtype Argument_List is Util.Commands.Argument_List;

   Driver : Drivers.Driver_Type;

   procedure Gateway_Command (Command   : in Drivers.Command_Type'Class;
                              Args      : in Util.Commands.Argument_List'Class;
                              Arg_Pos   : in Positive;
                              Process   : access procedure (Gateway : in out Gateways.Gateway_Type;
                                                            Param   : in String);
                              Context   : in out Context_Type);

   procedure Initialize;

   --  Print the bbox API status.
   procedure Print_Status (Console : in Consoles.Console_Access;
                           Field   : in Field_Type;
                           Value   : in String);

   --  Print a ON/OFF status.
   procedure Print_On_Off (Console : in Consoles.Console_Access;
                           Field   : in Field_Type;
                           Value   : in String);

   --  Print a uptime.
   procedure Print_Uptime (Console : in Consoles.Console_Access;
                           Field   : in Field_Type;
                           Value   : in String);

   --  Print a performance measure in us or ms.
   procedure Print_Perf (Console : in Consoles.Console_Access;
                         Field   : in Field_Type;
                         Value   : in String);

end Druss.Commands;

Declare the Print_Perf procedure

Declare the Print_Perf procedure


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

with Util.Tests;
with AWA.Tests;

package AWA.Mail.Modules.Tests is

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

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

   --  Create an email message and verify its content.
   procedure Test_Create_Message (T : in out Test);

end AWA.Mail.Modules.Tests;

-----------------------------------------------------------------------
--  awa-mail-module-tests -- Unit tests for Mail module
--  Copyright (C) 2012, 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 AWA.Tests;

package AWA.Mail.Modules.Tests is

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

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

   --  Create an email message with the given template and verify its content.
   procedure Test_Mail_Message (T    : in out Test;
                                Name : in String);

   --  Create an email message and verify its content.
   procedure Test_Create_Message (T : in out Test);

   --  Create an email message with Cc: and verify its content.
   procedure Test_Cc_Message (T : in out Test);

   --  Create an email message with Bcc: and verify its content.
   procedure Test_Bcc_Message (T : in out Test);

end AWA.Mail.Modules.Tests;

Add new tests for mail Cc and Bcc

Add new tests for mail Cc and Bcc


with C_String;
with Interfaces.C;

package body POSIX.File is

  --
  -- Functions to map between flag sets and discrete types.
  --

  function Open_Access_Mode_To_Integer (Open_Access_Mode : in Open_Access_Mode_t)
    return Open_Flag_Integer_t is
  begin
    return Open_Access_Mode_Map (Open_Access_Mode);
  end Open_Access_Mode_To_Integer;

  function Open_Options_To_Integer (Open_Options : in Open_Options_t) return Open_Flag_Integer_t is
    Return_Options : Open_Flag_Integer_t := 0;
  begin
    for Open_Option in Open_Option_t range Open_Option_t'First .. Open_Option_t'Last loop
      if Open_Options (Open_Option) then
        Return_Options := Return_Options or Open_Option_Map (Open_Option);
      end if;
      --# assert (Open_Option <= Open_Option_t'Last) and
      --#        (Open_Option >= Open_Option_t'First);
    end loop;
    return Return_Options;
  end Open_Options_To_Integer;

  --
  -- Return False if any of the selected flags have been defined as invalid
  -- on the current platform.
  --

  function Check_Support
    (Access_Mode : in Open_Access_Mode_t;
     Options     : in Open_Options_t) return Boolean
  is
    Any_Unsupported : Boolean := False;
  begin
    if Open_Access_Mode_Map (Access_Mode) = Unsupported then
      Any_Unsupported := True;
    end if;
    if not Any_Unsupported then
      for Option in Open_Option_t range Open_Option_t'First .. Open_Option_t'Last loop
        if Options (Option) then
          if Open_Option_Map (Option) = Unsupported then
            Any_Unsupported := True;
          end if;
        end if;
      end loop;
    end if;
    return Any_Unsupported;
  end Check_Support;

  --
  -- File opening/creation.
  --

  function C_Open_Boundary
    (File_Name : in String;
     Flags     : in Open_Flag_Integer_t;
     Mode      : in Permissions.Mode_t) return Descriptor_t is
    --# hide C_Open_Boundary
    function C_Open
      (File_Name : in C_String.String_Not_Null_Ptr_t;
       Flags     : in Open_Flag_Integer_t;
       Mode      : in Permissions.Mode_t) return Descriptor_t;
    pragma Import (C, C_Open, "open");
  begin
    declare
      C_File_Name_Buffer : aliased Interfaces.C.char_array :=
        Interfaces.C.To_C (File_Name, Append_Nul => True);
    begin
      return C_Open
        (File_Name => C_String.To_C_String (C_File_Name_Buffer'Unchecked_Access),
         Flags     => Flags,
         Mode      => Mode);
    end;
  exception
    -- Do not propagate exceptions.
    when Storage_Error =>
      Error.Set_Error (Error.Error_Out_Of_Memory);
      return -1;
    when others =>
      Error.Set_Error (Error.Error_Unknown);
      return -1;
  end C_Open_Boundary;

  procedure Open
    (File_Name    : in String;
     Access_Mode  : in Open_Access_Mode_t;
     Options      : in Open_Options_t;
     Non_Blocking : in Boolean;
     Mode         : in Permissions.Mode_t;
     Descriptor   : out Descriptor_t;
     Error_Value  : out Error.Error_t)
  is
    C_Flags   : Open_Flag_Integer_t;
    Supported : Boolean;
  begin
    Supported := Check_Support
      (Access_Mode => Access_Mode,
       Options     => Options);

    -- Access mode and all options supported?
    if Supported then
      C_Flags := Open_Access_Mode_To_Integer (Access_Mode) or
                 Open_Options_To_Integer (Options);
      -- Reject long filename.
      if File_Name'Last > File_Name_t'Last then
        Descriptor  := -1;
        Error_Value := Error.Error_Name_Too_Long;
      else
        -- Set flags for non-blocking.
        if Non_Blocking then
          C_Flags := C_Flags or O_NONBLOCK;
        end if;

        -- Call system open() procedure.
        Descriptor := C_Open_Boundary
          (File_Name => File_Name,
           Flags     => C_Flags,
           Mode      => Mode);
        if Descriptor = -1 then
          Error_Value := Error.Get_Error;
        else
          Error_Value := Error.Error_None;
        end if;
      end if;
    else
      -- Unsupported options/access mode.
      Error_Value := Error.Error_Invalid_Argument;
      Descriptor  := -1;
    end if;
  end Open;

  procedure Open_Read_Only
    (File_Name    : in String;
     Non_Blocking : in Boolean;
     Descriptor   : out Descriptor_t;
     Error_Value  : out Error.Error_t)
  is
    Open_Options : constant Open_Options_t := Open_Options_t'(others => False);
  begin
    Open
      (File_Name    => File_Name,
       Access_Mode  => Read_Only,
       Non_Blocking => Non_Blocking,
       Options      => Open_Options,
       Mode         => Permissions.None,
       Descriptor   => Descriptor,
       Error_Value  => Error_Value);
  end Open_Read_Only;

  procedure Open_Write_Only
    (File_Name    : in String;
     Non_Blocking : in Boolean;
     Descriptor   : out Descriptor_t;
     Error_Value  : out Error.Error_t)
  is
    Open_Options : constant Open_Options_t := Open_Options_t'(others => False);
  begin
    Open
      (File_Name    => File_Name,
       Access_Mode  => Write_Only,
       Non_Blocking => Non_Blocking,
       Options      => Open_Options,
       Mode         => Permissions.None,
       Descriptor   => Descriptor,
       Error_Value  => Error_Value);
  end Open_Write_Only;

  procedure Open_Exclusive
    (File_Name    : in String;
     Non_Blocking : in Boolean;
     Mode         : in Permissions.Mode_t;
     Descriptor   : out Descriptor_t;
     Error_Value  : out Error.Error_t)
  is
    Open_Options : constant Open_Options_t :=
      Open_Options_t'(Create     => True,
                      Exclusive  => True,
                      others     => False);
  begin
    Open
      (File_Name    => File_Name,
       Access_Mode  => Write_Only,
       Non_Blocking => Non_Blocking,
       Options      => Open_Options,
       Mode         => Mode,
       Descriptor   => Descriptor,
       Error_Value  => Error_Value);
  end Open_Exclusive;

  procedure Open_Append
    (File_Name    : in String;
     Non_Blocking : in Boolean;
     Descriptor   : out Descriptor_t;
     Error_Value  : out Error.Error_t)
  is
    Open_Options : constant Open_Options_t :=
      Open_Options_t'(Append => True,
                      Create => True,
                      others => False);
  begin
    Open
      (File_Name    => File_Name,
       Access_Mode  => Write_Only,
       Non_Blocking => Non_Blocking,
       Options      => Open_Options,
       Mode         => Permissions.None,
       Descriptor   => Descriptor,
       Error_Value  => Error_Value);
  end Open_Append;

  procedure Open_Truncate
    (File_Name    : in String;
     Non_Blocking : in Boolean;
     Mode         : in Permissions.Mode_t;
     Descriptor   : out Descriptor_t;
     Error_Value  : out Error.Error_t)
  is
    Open_Options : constant Open_Options_t :=
      Open_Options_t'(Create     => True,
                      Truncate   => True,
                      others     => False);
  begin
    Open
      (File_Name    => File_Name,
       Access_Mode  => Write_Only,
       Non_Blocking => Non_Blocking,
       Options      => Open_Options,
       Mode         => Mode,
       Descriptor   => Descriptor,
       Error_Value  => Error_Value);
  end Open_Truncate;

  procedure Open_Read_Write
    (File_Name    : in String;
     Non_Blocking : in Boolean;
     Descriptor   : out Descriptor_t;
     Error_Value  : out Error.Error_t)
  is
    Open_Options : constant Open_Options_t := Open_Options_t'(others => False);
  begin
    Open
      (File_Name    => File_Name,
       Access_Mode  => Read_Write,
       Non_Blocking => Non_Blocking,
       Options      => Open_Options,
       Mode         => Permissions.None,
       Descriptor   => Descriptor,
       Error_Value  => Error_Value);
  end Open_Read_Write;

  procedure Open_Create
    (File_Name    : in String;
     Non_Blocking : in Boolean;
     Mode         : in Permissions.Mode_t;
     Descriptor   : out Descriptor_t;
     Error_Value  : out Error.Error_t)
  is
    Open_Options : constant Open_Options_t :=
      Open_Options_t'(Create => True,
                      others => False);
  begin
    Open
      (File_Name    => File_Name,
       Access_Mode  => Write_Only,
       Non_Blocking => Non_Blocking,
       Options      => Open_Options,
       Mode         => Mode,
       Descriptor   => Descriptor,
       Error_Value  => Error_Value);
  end Open_Create;

  --
  -- File permissions.
  --

  procedure Change_Descriptor_Mode
    (Descriptor  : in Valid_Descriptor_t;
     Mode        : in Permissions.Mode_t;
     Error_Value : out Error.Error_t)
  is
    Return_Value : Error.Return_Value_t;

    function C_fchmod
      (Descriptor : in Valid_Descriptor_t;
       Mode       : in Permissions.Mode_t) return Error.Return_Value_t;
    pragma Import (C, C_fchmod, "fchmod");
  begin
    Return_Value := C_fchmod
      (Descriptor => Descriptor,
       Mode       => Mode);
    case Return_Value is
      when -1 => Error_Value := Error.Get_Error;
      when 0  => Error_Value := Error.Error_None;
    end case;
  end Change_Descriptor_Mode;

  procedure Change_Mode
    (File_Name   : in String;
     Mode        : in Permissions.Mode_t;
     Error_Value : out Error.Error_t)
  is
    Descriptor : Descriptor_t;
  begin
    Open_Read_Only
      (File_Name    => File_Name,
       Non_Blocking => False,
       Descriptor   => Descriptor,
       Error_Value  => Error_Value);
    if Error_Value = Error.Error_None then
      Change_Descriptor_Mode
        (Descriptor  => Descriptor,
         Mode        => Mode,
         Error_Value => Error_Value);
    end if;
  end Change_Mode;

  --
  -- File ownership.
  --

  procedure Change_Descriptor_Ownership
    (Descriptor  : in Valid_Descriptor_t;
     Owner       : in User_DB.User_ID_t;
     Group       : in User_DB.Group_ID_t;
     Error_Value : out Error.Error_t)
  is
    Return_Value : Error.Return_Value_t;

    function C_fchown
      (Descriptor : in Valid_Descriptor_t;
       Owner      : in User_DB.User_ID_t;
       Group      : in User_DB.Group_ID_t) return Error.Return_Value_t;
    pragma Import (C, C_fchown, "fchown");
  begin
    Return_Value := C_fchown
      (Descriptor => Descriptor,
       Owner      => Owner,
       Group      => Group);
    case Return_Value is
      when -1 => Error_Value := Error.Get_Error;
      when 0  => Error_Value := Error.Error_None;
    end case;
  end Change_Descriptor_Ownership;

  procedure Change_Ownership
    (File_Name   : in String;
     Owner       : in User_DB.User_ID_t;
     Group       : in User_DB.Group_ID_t;
     Error_Value : out Error.Error_t)
  is
    Descriptor : Descriptor_t;
  begin
    Open_Read_Only
      (File_Name    => File_Name,
       Non_Blocking => False,
       Descriptor   => Descriptor,
       Error_Value  => Error_Value);
    if Error_Value = Error.Error_None then
      Change_Descriptor_Ownership
        (Descriptor  => Descriptor,
         Owner       => Owner,
         Group       => Group,
         Error_Value => Error_Value);
    end if;
  end Change_Ownership;

  --
  -- File removal.
  --

  function Unlink_Boundary (File_Name : in String)
    return Error.Return_Value_t is
    --# hide Unlink_Boundary
    function C_Unlink (File_Name : in C_String.String_Not_Null_Ptr_t)
      return Error.Return_Value_t;
    pragma Import (C, C_Unlink, "unlink");
  begin
    declare
      C_File_Name_Buffer : aliased Interfaces.C.char_array :=
        Interfaces.C.To_C (File_Name, Append_Nul => True);
    begin
      return C_Unlink (C_String.To_C_String (C_File_Name_Buffer'Unchecked_Access));
    end;
  exception
    -- Do not propagate exceptions.
    when Storage_Error =>
      Error.Set_Error (Error.Error_Out_Of_Memory);
      return -1;
    when others =>
      Error.Set_Error (Error.Error_Unknown);
      return -1;
  end Unlink_Boundary;

  procedure Unlink
    (File_Name   : in String;
     Error_Value : out Error.Error_t) is
  begin
    case Unlink_Boundary (File_Name) is
      when  0 => Error_Value := Error.Error_None;
      when -1 => Error_Value := Error.Get_Error;
    end case;
  end Unlink;

  --
  -- File closing.
  --

  procedure Close
    (Descriptor  : in Valid_Descriptor_t;
     Error_Value : out Error.Error_t)
  is
    function C_Close (Descriptor : in Valid_Descriptor_t) return Error.Return_Value_t;
    pragma Import (C, C_Close, "close");
  begin
    case C_Close (Descriptor) is
      when  0 => Error_Value := Error.Error_None;
      when -1 => Error_Value := Error.Get_Error;
    end case;
  end Close;

end POSIX.File;

with C_String;
with Interfaces.C;

package body POSIX.File is

  --
  -- Functions to map between flag sets and discrete types.
  --

  function Open_Access_Mode_To_Integer (Open_Access_Mode : in Open_Access_Mode_t)
    return Open_Flag_Integer_t is
  begin
    return Open_Access_Mode_Map (Open_Access_Mode);
  end Open_Access_Mode_To_Integer;

  function Open_Options_To_Integer (Open_Options : in Open_Options_t) return Open_Flag_Integer_t is
    Return_Options : Open_Flag_Integer_t := 0;
  begin
    for Open_Option in Open_Option_t range Open_Option_t'First .. Open_Option_t'Last loop
      if Open_Options (Open_Option) then
        Return_Options := Return_Options or Open_Option_Map (Open_Option);
      end if;
      --# assert (Open_Option <= Open_Option_t'Last) and
      --#        (Open_Option >= Open_Option_t'First);
    end loop;
    return Return_Options;
  end Open_Options_To_Integer;

  --
  -- Return False if any of the selected flags have been defined as invalid
  -- on the current platform.
  --

  function Check_Support
    (Access_Mode : in Open_Access_Mode_t;
     Options     : in Open_Options_t) return Boolean
  is
    Any_Unsupported : Boolean := False;
  begin
    if Open_Access_Mode_Map (Access_Mode) = Unsupported then
      Any_Unsupported := True;
    end if;
    if not Any_Unsupported then
      for Option in Open_Option_t range Open_Option_t'First .. Open_Option_t'Last loop
        if Options (Option) then
          if Open_Option_Map (Option) = Unsupported then
            Any_Unsupported := True;
          end if;
        end if;
        --# assert (Option <= Open_Option_t'Last) and
        --#        (Option >= Open_Option_t'First);
      end loop;
    end if;
    return Any_Unsupported;
  end Check_Support;

  --
  -- File opening/creation.
  --

  function C_Open_Boundary
    (File_Name : in String;
     Flags     : in Open_Flag_Integer_t;
     Mode      : in Permissions.Mode_t) return Descriptor_t is
    --# hide C_Open_Boundary
    function C_Open
      (File_Name : in C_String.String_Not_Null_Ptr_t;
       Flags     : in Open_Flag_Integer_t;
       Mode      : in Permissions.Mode_t) return Descriptor_t;
    pragma Import (C, C_Open, "open");
  begin
    declare
      C_File_Name_Buffer : aliased Interfaces.C.char_array :=
        Interfaces.C.To_C (File_Name, Append_Nul => True);
    begin
      return C_Open
        (File_Name => C_String.To_C_String (C_File_Name_Buffer'Unchecked_Access),
         Flags     => Flags,
         Mode      => Mode);
    end;
  exception
    -- Do not propagate exceptions.
    when Storage_Error =>
      Error.Set_Error (Error.Error_Out_Of_Memory);
      return -1;
    when others =>
      Error.Set_Error (Error.Error_Unknown);
      return -1;
  end C_Open_Boundary;

  procedure Open
    (File_Name    : in String;
     Access_Mode  : in Open_Access_Mode_t;
     Options      : in Open_Options_t;
     Non_Blocking : in Boolean;
     Mode         : in Permissions.Mode_t;
     Descriptor   : out Descriptor_t;
     Error_Value  : out Error.Error_t)
  is
    C_Flags   : Open_Flag_Integer_t;
    Supported : Boolean;
  begin
    Supported := Check_Support
      (Access_Mode => Access_Mode,
       Options     => Options);

    -- Access mode and all options supported?
    if Supported then
      C_Flags := Open_Access_Mode_To_Integer (Access_Mode) or
                 Open_Options_To_Integer (Options);
      -- Reject long filename.
      if File_Name'Last > File_Name_t'Last then
        Descriptor  := -1;
        Error_Value := Error.Error_Name_Too_Long;
      else
        -- Set flags for non-blocking.
        if Non_Blocking then
          C_Flags := C_Flags or O_NONBLOCK;
        end if;

        -- Call system open() procedure.
        Descriptor := C_Open_Boundary
          (File_Name => File_Name,
           Flags     => C_Flags,
           Mode      => Mode);
        if Descriptor = -1 then
          Error_Value := Error.Get_Error;
        else
          Error_Value := Error.Error_None;
        end if;
      end if;
    else
      -- Unsupported options/access mode.
      Error_Value := Error.Error_Invalid_Argument;
      Descriptor  := -1;
    end if;
  end Open;

  procedure Open_Read_Only
    (File_Name    : in String;
     Non_Blocking : in Boolean;
     Descriptor   : out Descriptor_t;
     Error_Value  : out Error.Error_t)
  is
    Open_Options : constant Open_Options_t := Open_Options_t'(others => False);
  begin
    Open
      (File_Name    => File_Name,
       Access_Mode  => Read_Only,
       Non_Blocking => Non_Blocking,
       Options      => Open_Options,
       Mode         => Permissions.None,
       Descriptor   => Descriptor,
       Error_Value  => Error_Value);
  end Open_Read_Only;

  procedure Open_Write_Only
    (File_Name    : in String;
     Non_Blocking : in Boolean;
     Descriptor   : out Descriptor_t;
     Error_Value  : out Error.Error_t)
  is
    Open_Options : constant Open_Options_t := Open_Options_t'(others => False);
  begin
    Open
      (File_Name    => File_Name,
       Access_Mode  => Write_Only,
       Non_Blocking => Non_Blocking,
       Options      => Open_Options,
       Mode         => Permissions.None,
       Descriptor   => Descriptor,
       Error_Value  => Error_Value);
  end Open_Write_Only;

  procedure Open_Exclusive
    (File_Name    : in String;
     Non_Blocking : in Boolean;
     Mode         : in Permissions.Mode_t;
     Descriptor   : out Descriptor_t;
     Error_Value  : out Error.Error_t)
  is
    Open_Options : constant Open_Options_t :=
      Open_Options_t'(Create     => True,
                      Exclusive  => True,
                      others     => False);
  begin
    Open
      (File_Name    => File_Name,
       Access_Mode  => Write_Only,
       Non_Blocking => Non_Blocking,
       Options      => Open_Options,
       Mode         => Mode,
       Descriptor   => Descriptor,
       Error_Value  => Error_Value);
  end Open_Exclusive;

  procedure Open_Append
    (File_Name    : in String;
     Non_Blocking : in Boolean;
     Descriptor   : out Descriptor_t;
     Error_Value  : out Error.Error_t)
  is
    Open_Options : constant Open_Options_t :=
      Open_Options_t'(Append => True,
                      Create => True,
                      others => False);
  begin
    Open
      (File_Name    => File_Name,
       Access_Mode  => Write_Only,
       Non_Blocking => Non_Blocking,
       Options      => Open_Options,
       Mode         => Permissions.None,
       Descriptor   => Descriptor,
       Error_Value  => Error_Value);
  end Open_Append;

  procedure Open_Truncate
    (File_Name    : in String;
     Non_Blocking : in Boolean;
     Mode         : in Permissions.Mode_t;
     Descriptor   : out Descriptor_t;
     Error_Value  : out Error.Error_t)
  is
    Open_Options : constant Open_Options_t :=
      Open_Options_t'(Create     => True,
                      Truncate   => True,
                      others     => False);
  begin
    Open
      (File_Name    => File_Name,
       Access_Mode  => Write_Only,
       Non_Blocking => Non_Blocking,
       Options      => Open_Options,
       Mode         => Mode,
       Descriptor   => Descriptor,
       Error_Value  => Error_Value);
  end Open_Truncate;

  procedure Open_Read_Write
    (File_Name    : in String;
     Non_Blocking : in Boolean;
     Descriptor   : out Descriptor_t;
     Error_Value  : out Error.Error_t)
  is
    Open_Options : constant Open_Options_t := Open_Options_t'(others => False);
  begin
    Open
      (File_Name    => File_Name,
       Access_Mode  => Read_Write,
       Non_Blocking => Non_Blocking,
       Options      => Open_Options,
       Mode         => Permissions.None,
       Descriptor   => Descriptor,
       Error_Value  => Error_Value);
  end Open_Read_Write;

  procedure Open_Create
    (File_Name    : in String;
     Non_Blocking : in Boolean;
     Mode         : in Permissions.Mode_t;
     Descriptor   : out Descriptor_t;
     Error_Value  : out Error.Error_t)
  is
    Open_Options : constant Open_Options_t :=
      Open_Options_t'(Create => True,
                      others => False);
  begin
    Open
      (File_Name    => File_Name,
       Access_Mode  => Write_Only,
       Non_Blocking => Non_Blocking,
       Options      => Open_Options,
       Mode         => Mode,
       Descriptor   => Descriptor,
       Error_Value  => Error_Value);
  end Open_Create;

  --
  -- File permissions.
  --

  procedure Change_Descriptor_Mode
    (Descriptor  : in Valid_Descriptor_t;
     Mode        : in Permissions.Mode_t;
     Error_Value : out Error.Error_t)
  is
    Return_Value : Error.Return_Value_t;

    function C_fchmod
      (Descriptor : in Valid_Descriptor_t;
       Mode       : in Permissions.Mode_t) return Error.Return_Value_t;
    pragma Import (C, C_fchmod, "fchmod");
  begin
    Return_Value := C_fchmod
      (Descriptor => Descriptor,
       Mode       => Mode);
    case Return_Value is
      when -1 => Error_Value := Error.Get_Error;
      when 0  => Error_Value := Error.Error_None;
    end case;
  end Change_Descriptor_Mode;

  procedure Change_Mode
    (File_Name   : in String;
     Mode        : in Permissions.Mode_t;
     Error_Value : out Error.Error_t)
  is
    Descriptor : Descriptor_t;
  begin
    Open_Read_Only
      (File_Name    => File_Name,
       Non_Blocking => False,
       Descriptor   => Descriptor,
       Error_Value  => Error_Value);
    if Error_Value = Error.Error_None then
      Change_Descriptor_Mode
        (Descriptor  => Descriptor,
         Mode        => Mode,
         Error_Value => Error_Value);
    end if;
  end Change_Mode;

  --
  -- File ownership.
  --

  procedure Change_Descriptor_Ownership
    (Descriptor  : in Valid_Descriptor_t;
     Owner       : in User_DB.User_ID_t;
     Group       : in User_DB.Group_ID_t;
     Error_Value : out Error.Error_t)
  is
    Return_Value : Error.Return_Value_t;

    function C_fchown
      (Descriptor : in Valid_Descriptor_t;
       Owner      : in User_DB.User_ID_t;
       Group      : in User_DB.Group_ID_t) return Error.Return_Value_t;
    pragma Import (C, C_fchown, "fchown");
  begin
    Return_Value := C_fchown
      (Descriptor => Descriptor,
       Owner      => Owner,
       Group      => Group);
    case Return_Value is
      when -1 => Error_Value := Error.Get_Error;
      when 0  => Error_Value := Error.Error_None;
    end case;
  end Change_Descriptor_Ownership;

  procedure Change_Ownership
    (File_Name   : in String;
     Owner       : in User_DB.User_ID_t;
     Group       : in User_DB.Group_ID_t;
     Error_Value : out Error.Error_t)
  is
    Descriptor : Descriptor_t;
  begin
    Open_Read_Only
      (File_Name    => File_Name,
       Non_Blocking => False,
       Descriptor   => Descriptor,
       Error_Value  => Error_Value);
    if Error_Value = Error.Error_None then
      Change_Descriptor_Ownership
        (Descriptor  => Descriptor,
         Owner       => Owner,
         Group       => Group,
         Error_Value => Error_Value);
    end if;
  end Change_Ownership;

  --
  -- File removal.
  --

  function Unlink_Boundary (File_Name : in String)
    return Error.Return_Value_t is
    --# hide Unlink_Boundary
    function C_Unlink (File_Name : in C_String.String_Not_Null_Ptr_t)
      return Error.Return_Value_t;
    pragma Import (C, C_Unlink, "unlink");
  begin
    declare
      C_File_Name_Buffer : aliased Interfaces.C.char_array :=
        Interfaces.C.To_C (File_Name, Append_Nul => True);
    begin
      return C_Unlink (C_String.To_C_String (C_File_Name_Buffer'Unchecked_Access));
    end;
  exception
    -- Do not propagate exceptions.
    when Storage_Error =>
      Error.Set_Error (Error.Error_Out_Of_Memory);
      return -1;
    when others =>
      Error.Set_Error (Error.Error_Unknown);
      return -1;
  end Unlink_Boundary;

  procedure Unlink
    (File_Name   : in String;
     Error_Value : out Error.Error_t) is
  begin
    case Unlink_Boundary (File_Name) is
      when  0 => Error_Value := Error.Error_None;
      when -1 => Error_Value := Error.Get_Error;
    end case;
  end Unlink;

  --
  -- File closing.
  --

  procedure Close
    (Descriptor  : in Valid_Descriptor_t;
     Error_Value : out Error.Error_t)
  is
    function C_Close (Descriptor : in Valid_Descriptor_t) return Error.Return_Value_t;
    pragma Import (C, C_Close, "close");
  begin
    case C_Close (Descriptor) is
      when  0 => Error_Value := Error.Error_None;
      when -1 => Error_Value := Error.Get_Error;
    end case;
  end Close;

end POSIX.File;

Add loop assertion.

Add loop assertion.