This is the mail archive of the gcc-patches@gcc.gnu.org mailing list for the GCC project.


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]
Other format: [Raw text]

[Patch, Ada] Internationalization of Ada.Directories(MinGW) and Fix PR/21346


Hello.

MinGW-version Ada.Directories can not take non-ascii filenames. (Read
http://gcc.gnu.org/ml/gcc/2006-10/msg00061.html)
*-mingw packages of this fix take filenames as UTF-8, support mark of
Windows-path like colon, backslash, and local-timestamps.
Also, this fix corrects PR/21346(function Compose) for all platforms.
Six new files(attached) and two patches. (Attached two *-9x.ad? files
are not used. These files support for Windows98 and WindowsME.)

Note: AdaCore's current-developing-version GNAT PRO/GNAT GPL /*should*/
be enabled to take unicode filenames. But it does not work well. I
tested GNAT GPL 2006 and sent the report to AdaCore.

Index: gcc/ada/Makefile.in
===================================================================
--- Makefile.in.old     Sun Apr  9 05:11:21 2006
+++ Makefile.in Fri Oct 13 15:56:10 2006
@@ -1197,7 +1197,10 @@ endif
 ifeq ($(strip $(filter-out cygwin32% mingw32% pe,$(osys))),)
   LIBGNAT_TARGET_PAIRS = \
   a-calend.adb<a-calend-mingw.adb \
+  a-dirval.ads<a-dirval-mingw.ads \
   a-dirval.adb<a-dirval-mingw.adb \
+  a-direct.ads<a-direct-mingw-nt.ads \
+  a-direct.adb<a-direct-mingw-nt.adb \
   a-excpol.adb<a-excpol-abort.adb \
   a-intnam.ads<a-intnam-mingw.ads \
   a-numaux.adb<a-numaux-x86.adb \

Index: gcc/ada/a-direct.adb
===================================================================
--- a-direct.adb.old	Wed Feb 15 18:36:24 2006
+++ a-direct.adb	Fri Oct 13 20:29:14 2006
@@ -119,51 +119,35 @@ package body Ada.Directories is
       Last   : Natural;

    begin
-      --  First, deal with the invalid cases
-
-      if not Is_Valid_Path_Name (Containing_Directory) then
-         raise Name_Error;
-
-      elsif
-        Extension'Length = 0 and then (not Is_Valid_Simple_Name (Name))
-      then
-         raise Name_Error;
-
-      elsif Extension'Length /= 0 and then
-        (not Is_Valid_Simple_Name (Name & '.' & Extension))
-      then
-         raise Name_Error;
-
-         --  This is not an invalid case so build the path name
-
-      else
-         Last := Containing_Directory'Length;
+      Last := Containing_Directory'Length;
+      if Last > 0 then
          Result (1 .. Last) := Containing_Directory;
-
          --  Add a directory separator if needed
-
          if Result (Last) /= Dir_Separator then
             Last := Last + 1;
             Result (Last) := Dir_Separator;
          end if;
+      end if;

-         --  Add the file name
+      --  Add the file name

-         Result (Last + 1 .. Last + Name'Length) := Name;
-         Last := Last + Name'Length;
+      Result (Last + 1 .. Last + Name'Length) := Name;
+      Last := Last + Name'Length;

-         --  If extension was specified, add dot followed by this extension
+      --  If extension was specified, add dot followed by this extension

-         if Extension'Length /= 0 then
-            Last := Last + 1;
-            Result (Last) := '.';
-            Result (Last + 1 .. Last + Extension'Length) := Extension;
-            Last := Last + Extension'Length;
-         end if;
+      if Extension'Length /= 0 then
+         Last := Last + 1;
+         Result (Last) := '.';
+         Result (Last + 1 .. Last + Extension'Length) := Extension;
+         Last := Last + Extension'Length;
+      end if;

-         To_Lower_If_Case_Insensitive (Result (1 .. Last));
-         return Result (1 .. Last);
+      if not Is_Valid_Path_Name (Result (1 .. Last)) then
+         raise Name_Error;
       end if;
+      To_Lower_If_Case_Insensitive (Result (1 .. Last));
+      return Result (1 .. Last);
    end Compose;

    --------------------------

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT RUN-TIME COMPONENTS                         --
--                                                                          --
--                      A D A . D I R E C T O R I E S                       --
--                                                                          --
--                                 S p e c                                  --
--                            (Windows Version)                             --
--                                                                          --
--          Copyright (C) 2004-2005, Free Software Foundation, Inc.         --
--                                                                          --
-- This specification is derived for use with GNAT from AI-00248,  which is --
-- expected to be a part of a future expected revised Ada Reference Manual. --
-- The copyright notice above, and the license provisions that follow apply --
-- solely to the  contents of the part following the private keyword.       --
--                                                                          --
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
-- for  more details.  You should have  received  a copy of the GNU General --
-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
-- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
-- Boston, MA 02110-1301, USA.                                              --
--                                                                          --
-- As a special exception,  if other files  instantiate  generics from this --
-- unit, or you link  this unit with other files  to produce an executable, --
-- this  unit  does not  by itself cause  the resulting  executable  to  be --
-- covered  by the  GNU  General  Public  License.  This exception does not --
-- however invalidate  any other reasons why  the executable file  might be --
-- covered by the  GNU Public License.                                      --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------

--  Ada 2005: Implementation of Ada.Directories (AI95-00248). Note that this
--  unit is available without -gnat05. That seems reasonable, since you only
--  get it if you explicitly ask for it.

--  External files may be classified as directories, special files, or ordinary
--  files. A directory is an external file that is a container for files on
--  the target system. A special file is an external file that cannot be
--  created or read by a predefined Ada Input-Output package. External files
--  that are not special files or directories are called ordinary files.

--  A file name is a string identifying an external file. Similarly, a
--  directory name is a string identifying a directory. The interpretation of
--  file names and directory names is implementation-defined.

--  The full name of an external file is a full specification of the name of
--  the file. If the external environment allows alternative specifications of
--  the name (for example, abbreviations), the full name should not use such
--  alternatives. A full name typically will include the names of all of
--  directories that contain the item. The simple name of an external file is
--  the name of the item, not including any containing directory names. Unless
--  otherwise specified, a file name or directory name parameter to a
--  predefined Ada input-output subprogram can be a full name, a simple name,
--  or any other form of name supported by the implementation.

--  The default directory is the directory that is used if a directory or
--  file name is not a full name (that is, when the name does not fully
--  identify all of the containing directories).

--  A directory entry is a single item in a directory, identifying a single
--  external file (including directories and special files).

--  For each function that returns a string, the lower bound of the returned
--  value is 1.

--  This is the Windows version of this package

with Ada.Calendar;
with Ada.Finalization;
with Ada.IO_Exceptions;
private with Interfaces;
private with Ada.Unchecked_Deallocation;

package Ada.Directories is
   pragma Ada_05;
   --  To be removed later ???

   -----------------------------------
   -- Directory and File Operations --
   -----------------------------------

   function Current_Directory return String;
   --  Returns the full directory name for the current default directory. The
   --  name returned shall be suitable for a future call to Set_Directory.
   --  The exception Use_Error is propagated if a default directory is not
   --  supported by the external environment.

   procedure Set_Directory (Directory : String);
   --  Sets the current default directory. The exception Name_Error is
   --  propagated if the string given as Directory does not identify an
   --  existing directory. The exception Use_Error is propagated if the
   --  external environment does not support making Directory (in the absence
   --  of Name_Error) a default directory.

   procedure Create_Directory
     (New_Directory : String;
      Form          : String := "");
   --  Creates a directory with name New_Directory. The Form parameter can be
   --  used to give system-dependent characteristics of the directory; the
   --  interpretation of the Form parameter is implementation-defined. A null
   --  string for Form specifies the use of the default options of the
   --  implementation of the new directory. The exception Name_Error is
   --  propagated if the string given as New_Directory does not allow the
   --  identification of a directory. The exception Use_Error is propagated if
   --  the external environment does not support the creation of a directory
   --  with the given name (in the absence of Name_Error) and form.

   procedure Delete_Directory (Directory : String);
   --  Deletes an existing empty directory with name Directory. The exception
   --  Name_Error is propagated if the string given as Directory does not
   --  identify an existing directory. The exception Use_Error is propagated
   --  if the external environment does not support the deletion of the
   --  directory (or some portion of its contents) with the given name (in the
   --  absence of Name_Error).

   procedure Create_Path
     (New_Directory : String;
      Form          : String := "");
   --  Creates zero or more directories with name New_Directory. Each
   --  non-existent directory named by New_Directory is created. For example,
   --  on a typical Unix system, Create_Path ("/usr/me/my"); would create
   --  directory "me" in directory "usr", then create directory "my" in
   --  directory "me". The Form can be used to give system-dependent
   --  characteristics of the directory; the interpretation of the Form
   --  parameter is implementation-defined. A null string for Form specifies
   --  the use of the default options of the implementation of the new
   --  directory. The exception Name_Error is propagated if the string given
   --  as New_Directory does not allow the identification of any directory.
   --  The exception Use_Error is propagated if the external environment does
   --  not support the creation of any directories with the given name (in the
   --  absence of Name_Error) and form.

   procedure Delete_Tree (Directory : String);
   --  Deletes an existing directory with name Directory. The directory and
   --  all of its contents (possibly including other directories) are deleted.
   --  The exception Name_Error is propagated if the string given as Directory
   --  does not identify an existing directory. The exception Use_Error is
   --  propagated if the external environment does not support the deletion of
   --  the directory or some portion of its contents with the given name (in
   --  the absence of Name_Error). If Use_Error is propagated, it is
   --  unspecified if a portion of the contents of the directory are deleted.

   procedure Delete_File (Name : String);
   --  Deletes an existing ordinary or special file with Name. The exception
   --  Name_Error is propagated if the string given as Name does not identify
   --  an existing ordinary or special external file. The exception Use_Error
   --  is propagated if the external environment does not support the deletion
   --  of the file with the given name (in the absence of Name_Error).

   procedure Rename (Old_Name, New_Name : String);
   --  Renames an existing external file (including directories) with Old_Name
   --  to New_Name. The exception Name_Error is propagated if the string given
   --  as Old_Name does not identify an existing external file. The exception
   --  Use_Error is propagated if the external environment does not support the
   --  renaming of the file with the given name (in the absence of Name_Error).
   --  In particular, Use_Error is propagated if a file or directory already
   --  exists with New_Name.

   procedure Copy_File
     (Source_Name   : String;
      Target_Name   : String;
      Form          : String := "");
   --  Copies the contents of the existing external file with Source_Name
   --  to Target_Name. The resulting external file is a duplicate of the source
   --  external file. The Form can be used to give system-dependent
   --  characteristics of the resulting external file; the interpretation of
   --  the Form parameter is implementation-defined. Exception Name_Error is
   --  propagated if the string given as Source_Name does not identify an
   --  existing external ordinary or special file or if the string given as
   --  Target_Name does not allow the identification of an external file.
   --  The exception Use_Error is propagated if the external environment does
   --  not support the creating of the file with the name given by Target_Name
   --  and form given by Form, or copying of the file with the name given by
   --  Source_Name (in the absence of Name_Error).

   ----------------------------------------
   -- File and directory name operations --
   ----------------------------------------

   function Full_Name (Name : String) return String;
   --  Returns the full name corresponding to the file name specified by Name.
   --  The exception Name_Error is propagated if the string given as Name does
   --  not allow the identification of an external file (including directories
   --  and special files).

   function Simple_Name (Name : String) return String;
   --  Returns the simple name portion of the file name specified by Name. The
   --  exception Name_Error is propagated if the string given as Name does not
   --  allow the identification of an external file (including directories and
   --  special files).

   function Containing_Directory (Name : String) return String;
   --  Returns the name of the containing directory of the external file
   --  (including directories) identified by Name. If more than one directory
   --  can contain Name, the directory name returned is implementation-defined.
   --  The exception Name_Error is propagated if the string given as Name does
   --  not allow the identification of an external file. The exception
   --  Use_Error is propagated if the external file does not have a containing
   --  directory.

   function Extension (Name : String) return String;
   --  Returns the extension name corresponding to Name. The extension name is
   --  a portion of a simple name (not including any separator characters),
   --  typically used to identify the file class. If the external environment
   --  does not have extension names, then the null string is returned.
   --  The exception Name_Error is propagated if the string given as Name does
   --  not allow the identification of an external file.

   function Base_Name (Name : String) return String;
   --  Returns the base name corresponding to Name. The base name is the
   --  remainder of a simple name after removing any extension and extension
   --  separators. The exception Name_Error is propagated if the string given
   --  as Name does not allow the identification of an external file
   --  (including directories and special files).

   function Compose
     (Containing_Directory : String := "";
      Name                 : String;
      Extension            : String := "") return String;
   --  Returns the name of the external file with the specified
   --  Containing_Directory, Name, and Extension. If Extension is the null
   --  string, then Name is interpreted as a simple name; otherwise Name is
   --  interpreted as a base name. The exception Name_Error is propagated if
   --  the string given as Containing_Directory is not null and does not allow
   --  the identification of a directory, or if the string given as Extension
   --  is not null and is not a possible extension, or if the string given as
   --  Name is not a possible simple name (if Extension is null) or base name
   --  (if Extension is non-null).

   --------------------------------
   -- File and directory queries --
   --------------------------------

   type File_Kind is (Directory, Ordinary_File, Special_File);
   --  The type File_Kind represents the kind of file represented by an
   --  external file or directory.

   type File_Size is range 0 .. Long_Long_Integer'Last;
   --  The type File_Size represents the size of an external file

   function Exists (Name : String) return Boolean;
   --  Returns True if external file represented by Name exists, and False
   --  otherwise. The exception Name_Error is propagated if the string given as
   --  Name does not allow the identification of an external file (including
   --  directories and special files).

   function Kind (Name : String) return File_Kind;
   --  Returns the kind of external file represented by Name. The exception
   --  Name_Error is propagated if the string given as Name does not allow the
   --  identification of an existing external file.

   function Size (Name : String) return File_Size;
   --  Returns the size of the external file represented by Name. The size of
   --  an external file is the number of stream elements contained in the file.
   --  If the external file is discontiguous (not all elements exist), the
   --  result is implementation-defined. If the external file is not an
   --  ordinary file, the result is implementation-defined. The exception
   --  Name_Error is propagated if the string given as Name does not allow the
   --  identification of an existing external file. The exception
   --  Constraint_Error is propagated if the file size is not a value of type
   --  File_Size.

   function Modification_Time (Name : String) return Ada.Calendar.Time;
   --  Returns the time that the external file represented by Name was most
   --  recently modified. If the external file is not an ordinary file, the
   --  result is implementation-defined. The exception Name_Error is propagated
   --  if the string given as Name does not allow the identification of an
   --  existing external file. The exception Use_Error is propagated if the
   --  external environment does not support the reading the modification time
   --  of the file with the name given by Name (in the absence of Name_Error).

   -------------------------
   -- Directory Searching --
   -------------------------

   type Directory_Entry_Type is limited private;
   --  The type Directory_Entry_Type represents a single item in a directory.
   --  These items can only be created by the Get_Next_Entry procedure in this
   --  package. Information about the item can be obtained from the functions
   --  declared in this package. A default initialized object of this type is
   --  invalid; objects returned from Get_Next_Entry are valid.

   type Filter_Type is array (File_Kind) of Boolean;
   --  The type Filter_Type specifies which directory entries are provided from
   --  a search operation. If the Directory component is True, directory
   --  entries representing directories are provided. If the Ordinary_File
   --  component is True, directory entries representing ordinary files are
   --  provided. If the Special_File component is True, directory entries
   --  representing special files are provided.

   type Search_Type is limited private;
   --  The type Search_Type contains the state of a directory search. A
   --  default-initialized Search_Type object has no entries available
   --  (More_Entries returns False).

   procedure Start_Search
     (Search    : in out Search_Type;
      Directory : String;
      Pattern   : String;
      Filter    : Filter_Type := (others => True));
   --  Starts a search in the directory entry in the directory named by
   --  Directory for entries matching Pattern. Pattern represents a file name
   --  matching pattern. If Pattern is null, all items in the directory are
   --  matched; otherwise, the interpretation of Pattern is implementation-
   --  defined. Only items which match Filter will be returned. After a
   --  successful call on Start_Search, the object Search may have entries
   --  available, but it may have no entries available if no files or
   --  directories match Pattern and Filter. The exception Name_Error is
   --  propagated if the string given by Directory does not identify an
   --  existing directory, or if Pattern does not allow the identification of
   --  any possible external file or directory. The exception Use_Error is
   --  propagated if the external environment does not support the searching
   --  of the directory with the given name (in the absence of Name_Error).

   procedure End_Search (Search : in out Search_Type);
   --  Ends the search represented by Search. After a successful call on
   --  End_Search, the object Search will have no entries available. Note
   --  that is is not necessary to call End_Search if the call to Start_Search
   --  was unsuccessful and raised an exception (but it is harmless to make
   --  the call in this case)>

   function More_Entries (Search : Search_Type) return Boolean;
   --  Returns True if more entries are available to be returned by a call
   --  to Get_Next_Entry for the specified search object, and False otherwise.

   procedure Get_Next_Entry
     (Search          : in out Search_Type;
      Directory_Entry : out Directory_Entry_Type);
   --  Returns the next Directory_Entry for the search described by Search that
   --  matches the pattern and filter. If no further matches are available,
   --  Status_Error is raised. It is implementation-defined as to whether the
   --  results returned by this routine are altered if the contents of the
   --  directory are altered while the Search object is valid (for example, by
   --  another program). The exception Use_Error is propagated if the external
   --  environment does not support continued searching of the directory
   --  represented by Search.

   -------------------------------------
   -- Operations on Directory Entries --
   -------------------------------------

   function Simple_Name (Directory_Entry : Directory_Entry_Type) return String;
   --  Returns the simple external name of the external file (including
   --  directories) represented by Directory_Entry. The format of the name
   --  returned is implementation-defined. The exception Status_Error is
   --  propagated if Directory_Entry is invalid.

   function Full_Name (Directory_Entry : Directory_Entry_Type) return String;
   --  Returns the full external name of the external file (including
   --  directories) represented by Directory_Entry. The format of the name
   --  returned is implementation-defined. The exception Status_Error is
   --  propagated if Directory_Entry is invalid.

   function Kind (Directory_Entry : Directory_Entry_Type) return File_Kind;
   --  Returns the kind of external file represented by Directory_Entry. The
   --  exception Status_Error is propagated if Directory_Entry is invalid.

   function Size (Directory_Entry : Directory_Entry_Type) return File_Size;
   --  Returns the size of the external file represented by Directory_Entry.
   --  The size of an external file is the number of stream elements contained
   --  in the file. If the external file is discontiguous (not all elements
   --  exist), the result is implementation-defined. If the external file
   --  represented by Directory_Entry is not an ordinary file, the result is
   --  implementation-defined. The exception Status_Error is propagated if
   --  Directory_Entry is invalid. The exception Constraint_Error is propagated
   --  if the file size is not a value of type File_Size.

   function Modification_Time
     (Directory_Entry : Directory_Entry_Type) return Ada.Calendar.Time;
   --  Returns the time that the external file represented by Directory_Entry
   --  was most recently modified. If the external file represented by
   --  Directory_Entry is not an ordinary file, the result is
   --  implementation-defined. The exception Status_Error is propagated if
   --  Directory_Entry is invalid. The exception Use_Error is propagated if
   --  the external environment does not support the reading the modification
   --  time of the file represented by Directory_Entry.

   ----------------
   -- Exceptions --
   ----------------

   Status_Error : exception renames Ada.IO_Exceptions.Status_Error;
   Name_Error   : exception renames Ada.IO_Exceptions.Name_Error;
   Use_Error    : exception renames Ada.IO_Exceptions.Use_Error;
   Device_Error : exception renames Ada.IO_Exceptions.Device_Error;

private

   --  Windows API

   type DBCS_String is new String;

   MAX_PATH : constant := 260;  --  includes last NUL

   type FILETIME is record
      LowDateTime  : Interfaces.Unsigned_32;
      HighDateTime : Interfaces.Unsigned_32;
   end record;
   pragma Convention (C, FILETIME);

   FILE_ATTRIBUTE_READONLY            : constant := 16#00000001#;
   FILE_ATTRIBUTE_HIDDEN              : constant := 16#00000002#;
   FILE_ATTRIBUTE_SYSTEM              : constant := 16#00000004#;
   FILE_ATTRIBUTE_DIRECTORY           : constant := 16#00000010#;
   FILE_ATTRIBUTE_ARCHIVE             : constant := 16#00000020#;
   FILE_ATTRIBUTE_DEVICE              : constant := 16#00000040#;
   FILE_ATTRIBUTE_NORMAL              : constant := 16#00000080#;
   FILE_ATTRIBUTE_TEMPORARY           : constant := 16#00000100#;
   FILE_ATTRIBUTE_SPARSE_FILE         : constant := 16#00000200#;
   FILE_ATTRIBUTE_REPARSE_POINT       : constant := 16#00000400#;
   FILE_ATTRIBUTE_COMPRESSED          : constant := 16#00000800#;
   FILE_ATTRIBUTE_OFFLINE             : constant := 16#00001000#;
   FILE_ATTRIBUTE_NOT_CONTENT_INDEXED : constant := 16#00002000#;
   FILE_ATTRIBUTE_ENCRYPTED           : constant := 16#00004000#;
   FILE_ATTRIBUTE_VALID_FLAGS         : constant := 16#00007fb7#;
   FILE_ATTRIBUTE_VALID_SET_FLAGS     : constant := 16#000031a7#;

   type Character_Access is access all Character;
   type Wide_Character_Access is access all Wide_Character;

   function GetFullPathNameA (
     FileName : access constant Character;
     BufferLength : Interfaces.Unsigned_32;
     Buffer : access constant Character;
     FilePart : access Character_Access) return Interfaces.Unsigned_32;
   function GetFullPathNameW (
     FileName : access constant Wide_Character;
     BufferLength : Interfaces.Unsigned_32;
     Buffer : access constant Wide_Character;
     FilePart : access Wide_Character_Access) return Interfaces.Unsigned_32;
   pragma Import (stdcall, GetFullPathNameA, "GetFullPathNameA");
   pragma Import (stdcall, GetFullPathNameW, "GetFullPathNameW");

   function GetLongPathNameA (
     ShortPath : access constant Character;
     LongPath : access Character;
     Buffer : Interfaces.Unsigned_32) return Interfaces.Unsigned_32;
   function GetLongPathNameW (
     ShortPath : access constant Wide_Character;
     LongPath : access Wide_Character;
     Buffer : Interfaces.Unsigned_32) return Interfaces.Unsigned_32;
   pragma Import (stdcall, GetLongPathNameA, "GetLongPathNameA");
   pragma Import (stdcall, GetLongPathNameW, "GetLongPathNameW");

   type WIN32_FIND_DATAA is record
      FileAttributes    : Interfaces.Unsigned_32;
      CreationTime      : aliased FILETIME;
      LastAccessTime    : aliased FILETIME;
      LastWriteTime     : aliased FILETIME;
      FileSizeHigh      : Interfaces.Unsigned_32;
      FileSizeLow       : Interfaces.Unsigned_32;
      Reserved0         : Interfaces.Unsigned_32;
      Reserved1         : Interfaces.Unsigned_32;
      FileName          : DBCS_String (1 .. MAX_PATH);
      AlternateFileName : DBCS_String (1 .. 14);
   end record;
   pragma Convention (C, WIN32_FIND_DATAA);

   type WIN32_FIND_DATAW is record
      FileAttributes    : Interfaces.Unsigned_32;
      CreationTime      : aliased FILETIME;
      LastAccessTime    : aliased FILETIME;
      LastWriteTime     : aliased FILETIME;
      FileSizeHigh      : Interfaces.Unsigned_32;
      FileSizeLow       : Interfaces.Unsigned_32;
      Reserved0         : Interfaces.Unsigned_32;
      Reserved1         : Interfaces.Unsigned_32;
      FileName          : Wide_String (1 .. MAX_PATH);
      AlternateFileName : Wide_String (1 .. 14);
   end record;
   pragma Convention (C, WIN32_FIND_DATAW);

   function FindFirstFileA (FileName : access constant Character;
      FindFileData : access WIN32_FIND_DATAA) return Interfaces.Unsigned_32;
   function FindFirstFileW (FileName : access constant Wide_Character;
      FindFileData : access WIN32_FIND_DATAW) return Interfaces.Unsigned_32;
   pragma Import (stdcall, FindFirstFileA, "FindFirstFileA");
   pragma Import (stdcall, FindFirstFileW, "FindFirstFileW");

   INVALID_HANDLE_VALUE : constant := Interfaces.Unsigned_32'Last;

   function FindNextFileA (FindFile : Interfaces.Unsigned_32;
      FindFileData : access WIN32_FIND_DATAA) return Interfaces.Unsigned_32;
   function FindNextFileW (FindFile : Interfaces.Unsigned_32;
      FindFileData : access WIN32_FIND_DATAW) return Interfaces.Unsigned_32;
   pragma Import (stdcall, FindNextFileA, "FindNextFileA");
   pragma Import (stdcall, FindNextFileW, "FindNextFileW");

   function FindClose (FindFile : Interfaces.Unsigned_32)
      return Interfaces.Unsigned_32;
   procedure FindClose (FindFile : Interfaces.Unsigned_32);
   pragma Import (stdcall, FindClose, "FindClose");

   type WIN32_FILE_ATTRIBUTE_DATA is record
      FileAttributes : Interfaces.Unsigned_32;
      CreationTime : aliased FILETIME;
      LastAccessTime : aliased FILETIME;
      LastWriteTime : aliased FILETIME;
      FileSizeHigh : Interfaces.Unsigned_32;
      FileSizeLow : Interfaces.Unsigned_32;
   end record;
   pragma Convention (C, WIN32_FILE_ATTRIBUTE_DATA);

   function GetFileAttributesExA (
      FileName : access Character;
      InfoLevelId : Interfaces.Unsigned_32;
      FileInformation : access WIN32_FILE_ATTRIBUTE_DATA)
      return Interfaces.Unsigned_32;
   function GetFileAttributesExW (
      FileName : access Wide_Character;
      InfoLevelId : Interfaces.Unsigned_32;
      FileInformation : access WIN32_FILE_ATTRIBUTE_DATA)
      return Interfaces.Unsigned_32;
   pragma Import (stdcall, GetFileAttributesExA, "GetFileAttributesExA");
   pragma Import (stdcall, GetFileAttributesExW, "GetFileAttributesExW");

   GetFileExInfoStandard : constant := 0;

   function GetCurrentDirectoryA (BufferLength : Interfaces.Unsigned_32;
      Buffer : access constant Character) return Interfaces.Unsigned_32;
   function GetCurrentDirectoryW (BufferLength : Interfaces.Unsigned_32;
      Buffer : access constant Wide_Character) return Interfaces.Unsigned_32;
   pragma Import (stdcall, GetCurrentDirectoryA, "GetCurrentDirectoryA");
   pragma Import (stdcall, GetCurrentDirectoryW, "GetCurrentDirectoryW");

   function SetCurrentDirectoryA (PathName : access constant Character)
      return Interfaces.Unsigned_32;
   function SetCurrentDirectoryW (PathName : access constant Wide_Character)
      return Interfaces.Unsigned_32;
   pragma Import (stdcall, SetCurrentDirectoryA, "SetCurrentDirectoryA");
   pragma Import (stdcall, SetCurrentDirectoryW, "SetCurrentDirectoryW");

   type SECURITY_ATTRIBUTES is null record; --  dummy

   function CreateDirectoryA (PathName : access constant Character;
      SecurityAttributes : access SECURITY_ATTRIBUTES)
      return Interfaces.Unsigned_32;
   function CreateDirectoryW (PathName : access constant Wide_Character;
      SecurityAttributes : access SECURITY_ATTRIBUTES)
      return Interfaces.Unsigned_32;
   pragma Import (stdcall, CreateDirectoryA, "CreateDirectoryA");
   pragma Import (stdcall, CreateDirectoryW, "CreateDirectoryW");

   function RemoveDirectoryA (PathName : access constant Character)
      return Interfaces.Unsigned_32;
   function RemoveDirectoryW (PathName : access constant Wide_Character)
      return Interfaces.Unsigned_32;
   pragma Import (stdcall, RemoveDirectoryA, "RemoveDirectoryA");
   pragma Import (stdcall, RemoveDirectoryW, "RemoveDirectoryW");

   function DeleteFileA (FileName : access constant Character)
      return Interfaces.Unsigned_32;
   function DeleteFileW (FileName : access constant Wide_Character)
      return Interfaces.Unsigned_32;
   pragma Import (stdcall, DeleteFileA, "DeleteFileA");
   pragma Import (stdcall, DeleteFileW, "DeleteFileW");

   function MoveFileExA (ExistingFileName : access constant Character;
      NewFileName : access constant Character;
      Flags : Interfaces.Unsigned_32) return Interfaces.Unsigned_32;
   function MoveFileExW (ExistingFileName : access constant Wide_Character;
      NewFileName : access constant Wide_Character;
      Flags : Interfaces.Unsigned_32) return Interfaces.Unsigned_32;
   pragma Import (stdcall, MoveFileExA, "MoveFileExA");
   pragma Import (stdcall, MoveFileExW, "MoveFileExW");

   function CopyFileA (ExistingFileName : access constant Character;
      NewFileName : access constant Character;
      FailIfExists : Interfaces.Unsigned_32) return Interfaces.Unsigned_32;
   function CopyFileW (ExistingFileName : access constant Wide_Character;
      NewFileName : access constant Wide_Character;
      FailIfExists : Interfaces.Unsigned_32) return Interfaces.Unsigned_32;
   pragma Import (stdcall, CopyFileA, "CopyFileA");
   pragma Import (stdcall, CopyFileW, "CopyFileW");

   function FileTimeToLocalFileTime (Time : access constant FILETIME;
      LocalTime : access FILETIME) return Interfaces.Unsigned_32;
   procedure FileTimeToLocalFileTime (Time : access constant FILETIME;
      LocalTime : access FILETIME);
   pragma Import (stdcall, FileTimeToLocalFileTime, "FileTimeToLocalFileTime");

   type SYSTEMTIME is record
      Year         : Interfaces.Unsigned_16;
      Month        : Interfaces.Unsigned_16;
      DayOfWeek    : Interfaces.Unsigned_16;
      Day          : Interfaces.Unsigned_16;
      Hour         : Interfaces.Unsigned_16;
      Minute       : Interfaces.Unsigned_16;
      Second       : Interfaces.Unsigned_16;
      Milliseconds : Interfaces.Unsigned_16;
   end record;
   pragma Convention (C, SYSTEMTIME);

   function FileTimeToSystemTime
     (File : access FILETIME;
      System : access SYSTEMTIME) return Interfaces.Unsigned_32;
   procedure FileTimeToSystemTime
     (File : access FILETIME;
      System : access SYSTEMTIME);
   pragma Import (stdcall, FileTimeToSystemTime, "FileTimeToSystemTime");

   function MultiByteToWideChar (
      CodePage : Interfaces.Unsigned_32;
      Flags : Interfaces.Unsigned_32;
      MultiByteStr : access constant Character;
      MultiByte : Interfaces.Integer_32;
      WideCharStr : access Wide_Character;
      Max : Interfaces.Integer_32) return Interfaces.Integer_32;
   pragma Import (stdcall, MultiByteToWideChar, "MultiByteToWideChar");

   function WideCharToMultiByte (
     CodePage : Interfaces.Unsigned_32;
     Flags : Interfaces.Unsigned_32;
     WideCharStr : access constant Wide_Character;
     WideChar : Interfaces.Integer_32;
     MultiByteStr : access Character;
     MultiByte : Interfaces.Integer_32;
     DefaultChar : access constant Character;
     UsedDefaultChar : access Interfaces.Unsigned_32)
     return Interfaces.Integer_32;
   pragma Import (stdcall, WideCharToMultiByte, "WideCharToMultiByte");

   CP_ACP  : constant := 0;
   CP_UTF8 : constant := 65001;

   function GetLastError return Interfaces.Unsigned_32;
   pragma Import (stdcall, GetLastError, "GetLastError");

   ERROR_FILE_NOT_FOUND : constant :=  2;
   ERROR_PATH_NOT_FOUND : constant :=  3;
   ERROR_NO_MORE_FILES  : constant := 18;
   ERROR_FILE_EXISTS    : constant := 80;

   function strlen (S : access constant Character)
      return Interfaces.Unsigned_32;
   function wcslen (S : access constant Wide_Character)
      return Interfaces.Unsigned_32;
   pragma Import (C, strlen, "strlen");
   pragma Import (C, wcslen, "wcslen");

   --  Type bodies

   type Search_Access is access all Search_Type;

   type Directory_Entry_Type is record
      Search : Search_Access;
      Is_Valid : Boolean := False;
      --  Single UTF-16 letter be encoded 6 UTF-8 bytes
      Simple_Name : String (1 .. MAX_PATH * 6);
      Simple_Length : Natural;
      Kind : File_Kind;
      Size : File_Size;
      Modification_Time : Ada.Calendar.Time;
   end record;

   type String_Access is access String;
   procedure Free is new Ada.Unchecked_Deallocation (String, String_Access);

   --  Search_Type need to be a controlled type, because it includes component
   --  of type Dir_Type (in GNAT.Directory_Operations) that need to be closed
   --  (if opened) during finalization.

   type Search_Type is new Ada.Finalization.Controlled with record
      Handle : Interfaces.Unsigned_32 := INVALID_HANDLE_VALUE;
      Path : String_Access;
      Filter : Filter_Type;
      Is_Valid : Boolean;
      Data : aliased WIN32_FIND_DATAA;
   end record;

   procedure Finalize (Search : in out Search_Type);
   --  Close the directory, if opened, and deallocate Value

   procedure End_Search (Search : in out Search_Type) renames Finalize;

end Ada.Directories;
------------------------------------------------------------------------------
--                                                                          --
--                         GNAT RUN-TIME COMPONENTS                         --
--                                                                          --
--                      A D A . D I R E C T O R I E S                       --
--                                                                          --
--                                 B o d y                                  --
--                            (Windows Version)                             --
--                                                                          --
--          Copyright (C) 2004-2005, Free Software Foundation, Inc.         --
--                                                                          --
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
-- for  more details.  You should have  received  a copy of the GNU General --
-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
-- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
-- Boston, MA 02110-1301, USA.                                              --
--                                                                          --
-- As a special exception,  if other files  instantiate  generics from this --
-- unit, or you link  this unit with other files  to produce an executable, --
-- this  unit  does not  by itself cause  the resulting  executable  to  be --
-- covered  by the  GNU  General  Public  License.  This exception does not --
-- however invalidate  any other reasons why  the executable file  might be --
-- covered by the  GNU Public License.                                      --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------

--  This is the Windows version of this package

with Ada.Directories.Validity; use Ada.Directories.Validity;
with Ada.Unchecked_Conversion;
package body Ada.Directories is

   function To_File_Kind (Attribute : Interfaces.Unsigned_32) return File_Kind;

   procedure UTF8_To_UTF16 (Source : in String;
      Dest : out Wide_String; Last : out Natural);
   procedure UTF16_To_UTF8 (Source : in Wide_String;
      Dest : out String; Last : out Natural);

   type Unsigned_64_Rec is record
      Low : Interfaces.Unsigned_32;
      High : Interfaces.Unsigned_32;
   end record;
   pragma Pack (Unsigned_64_Rec);

   function To_Unsigned_64 is new Ada.Unchecked_Conversion
      (Unsigned_64_Rec, Interfaces.Unsigned_64);

   function To_Time (Time : FILETIME) return Ada.Calendar.Time;

   ---------------
   -- Base_Name --
   ---------------

   function Base_Name (Name : String) return String is
      Simple : constant String := Simple_Name (Name);
      --  Simple'First is guaranteed to be 1
   begin
      --  Look for the last dot in the file name and return the part of the
      --  file name preceding this last dot. If the first dot is the first
      --  character of the file name, the base name is the empty string.
      for Pos in reverse Simple'Range loop
         if Simple (Pos) = '.' then
            return Simple (Simple'First .. Pos - 1);
         end if;
      end loop;
      --  If there is no dot, return the complete file name
      return Simple;
   end Base_Name;

   -------------
   -- Compose --
   -------------

   function Compose
     (Containing_Directory : String := "";
      Name                 : String;
      Extension            : String := "") return String
   is
      Result : String (1 .. Containing_Directory'Length +
                              Name'Length + Extension'Length + 2);
      Last   : Natural;
   begin
      Last := Containing_Directory'Length;
      if Last > 0 then
         Result (1 .. Last) := Containing_Directory;
         --  Add a directory separator if needed
         case Result (Last) is
            when '\' | '/' =>
               null;
            when others =>
               Last := Last + 1;
               Result (Last) := '\';
         end case;
      end if;
      --  Add the file name
      Result (Last + 1 .. Last + Name'Length) := Name;
      Last := Last + Name'Length;
      --  If extension was specified, add dot followed by this extension
      if Extension'Length /= 0 then
         Last := Last + 1;
         Result (Last) := '.';
         Result (Last + 1 .. Last + Extension'Length) := Extension;
         Last := Last + Extension'Length;
      end if;
      if not Is_Valid_Path_Name (Result (1 .. Last)) then
         raise Name_Error;
      end if;
      return Result (1 .. Last);
   end Compose;

   --------------------------
   -- Containing_Directory --
   --------------------------

   function Containing_Directory (Name : String) return String is
   begin
      --  First, the invalid case
      if not Is_Valid_Path_Name (Name) then
         raise Name_Error;
      else
         --  Get the directory name using GNAT.Directory_Operations.Dir_Name
         declare
            First : Positive := Name'First;
            Last : Natural := Name'Last;
         begin
            if First < Last and then Name (First + 1) = ':' then
               First := First + 2;
            end if;
            --  Delete Last Filename
            while Last >= First loop
               case Name (Last) is
                  when '\' | '/' | ':' =>
                     exit;
                  when others =>
                     null;
               end case;
               Last := Last - 1;
            end loop;
            --  Remove any trailing directory separator, except as the first
            --  character.
            while Last > First loop
               case Name (Last) is
                  when '\' | '/' =>
                     null;
                  when others =>
                     exit;
               end case;
               Last := Last - 1;
            end loop;
            --  Special case of current directory, identified by "."
            if First = Last and then Name (First) = '.' then
               return Current_Directory;
            else
               return Name (Name'First .. Last);
            end if;
         end;
      end if;
   end Containing_Directory;

   ---------------
   -- Copy_File --
   ---------------

   procedure Copy_File
     (Source_Name   : String;
      Target_Name   : String;
      Form          : String := "")
   is
      pragma Unreferenced (Form);
      use type Interfaces.Unsigned_32;
      Old_Buffer : Wide_String (1 .. Source_Name'Length + 1);
      Old_Last : Positive;
      New_Buffer : Wide_String (1 .. Target_Name'Length + 1);
      New_Last : Positive;
   begin
      UTF8_To_UTF16 (Source_Name, Old_Buffer, Old_Last);
      Old_Buffer (Old_Last + 1) := Wide_Character'Val (0);
      UTF8_To_UTF16 (Target_Name, New_Buffer, New_Last);
      New_Buffer (New_Last + 1) := Wide_Character'Val (0);
      --  Fail if Target_Name exists
      if CopyFileW (Old_Buffer (Old_Buffer'First)'Unrestricted_Access,
         New_Buffer (New_Buffer'First)'Unrestricted_Access, 1) = 0
      then
         case GetLastError is
            when ERROR_FILE_NOT_FOUND | ERROR_PATH_NOT_FOUND =>
               raise Name_Error;
            when others =>
               raise Use_Error;
         end case;
      end if;
   end Copy_File;

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

   procedure Create_Directory
     (New_Directory : String;
      Form          : String := "")
   is
      pragma Unreferenced (Form);
      use type Interfaces.Unsigned_32;
      --  UTF16 Length <= UTF8 Length, "+ 1" for NUL
      Buffer : Wide_String (1 .. New_Directory'Length + 1);
      Last : Positive;
   begin
      UTF8_To_UTF16 (New_Directory, Buffer, Last);
      Buffer (Last + 1) := Wide_Character'Val (0);
      if CreateDirectoryW
         (Buffer (Buffer'First)'Unrestricted_Access, null) = 0
      then
         case GetLastError is
            when ERROR_FILE_NOT_FOUND | ERROR_PATH_NOT_FOUND =>
               raise Name_Error;
            when others =>
               raise Use_Error;
         end case;
      end if;
   end Create_Directory;

   -----------------
   -- Create_Path --
   -----------------

   procedure Create_Path
     (New_Directory : String;
      Form          : String := "")
   is
      pragma Unreferenced (Form);
      First : Positive;
      Created : Natural;
      Last : Positive;
      Step : Boolean;
   begin
      --  First, the invalid case
      if not Is_Valid_Path_Name (New_Directory) then
         raise Name_Error;
      else
         First := New_Directory'First;
         if First < New_Directory'Last
            and then New_Directory (First + 1) = ':'
         then
            First := First + 2;
         end if;
         --  Create, if necessary, each directory in the path
         Created := First - 1;
         for J in First .. New_Directory'Last loop
            --  Look for the end of an intermediate directory
            case New_Directory (J) is
               when '\' | '/' =>
                  Step := True;
                  Last := J - 1;
               when others =>
                  Step := J = New_Directory'Last;
                  Last := J;
            end case;
            if Step then
               --  We have found a new intermediate directory
               --  each time we find a first directory separator.
               if Created < J then
                  declare
                     Step_Dir : String renames New_Directory
                        (New_Directory'First .. Last);
                  begin
                     case Kind (Step_Dir) is
                        when Ordinary_File | Special_File =>
                           raise Use_Error;
                        when Directory =>
                           null;
                     end case;
                  exception
                     when Name_Error =>
                        Create_Directory (Step_Dir);
                  end;
               end if;
               Created := J;
            end if;
         end loop;
      end if;
   end Create_Path;

   -----------------------
   -- Current_Directory --
   -----------------------

   function Current_Directory return String is
      Buffer : Wide_String (1 .. MAX_PATH);
      Length : constant Natural := Natural (GetCurrentDirectoryW
         (MAX_PATH, Buffer (Buffer'First)'Unrestricted_Access));
   begin
      if Length = 0 then
         raise Use_Error;
      else
         declare
            Result : String (1 .. Length * 6);
            Result_Last : Natural;
         begin
            UTF16_To_UTF8 (Buffer (1 .. Length), Result, Result_Last);
            return Result (1 .. Result_Last);
         end;
      end if;
   end Current_Directory;

   ----------------------
   -- Delete_Directory --
   ----------------------

   procedure Delete_Directory (Directory : String) is
      use type Interfaces.Unsigned_32;
      --  UTF16 Length <= UTF8 Length, "+ 1" for NUL
      Buffer : Wide_String (1 .. Directory'Length + 1);
      Last : Positive;
   begin
      UTF8_To_UTF16 (Directory, Buffer, Last);
      Buffer (Last + 1) := Wide_Character'Val (0);
      if RemoveDirectoryW (Buffer (Buffer'First)'Unrestricted_Access) = 0 then
         case GetLastError is
            when ERROR_FILE_NOT_FOUND | ERROR_PATH_NOT_FOUND =>
               raise Name_Error;
            when others =>
               raise Use_Error;
         end case;
      end if;
   end Delete_Directory;

   -----------------
   -- Delete_File --
   -----------------

   procedure Delete_File (Name : String) is
      use type Interfaces.Unsigned_32;
      --  UTF16 Length <= UTF8 Length, "+ 1" for NUL
      Buffer : Wide_String (1 .. Name'Length + 1);
      Last : Positive;
   begin
      UTF8_To_UTF16 (Name, Buffer, Last);
      Buffer (Last + 1) := Wide_Character'Val (0);
      if DeleteFileW (Buffer (Buffer'First)'Unrestricted_Access) = 0 then
         case GetLastError is
            when ERROR_FILE_NOT_FOUND | ERROR_PATH_NOT_FOUND =>
               raise Name_Error;
            when others =>
               raise Use_Error;
         end case;
      end if;
   end Delete_File;

   -----------------
   -- Delete_Tree --
   -----------------

   procedure Delete_Tree (Directory : String) is
      Search : Search_Type;
   begin
      Start_Search (Search, Directory, "*", (others => True));
      while More_Entries (Search) loop
         declare
            Directory_Entry : Directory_Entry_Type;
         begin
            Get_Next_Entry (Search, Directory_Entry);
            declare
               Name : String renames Full_Name (Directory_Entry);
            begin
               case Kind (Directory_Entry) is
                  when Special_File =>
                     raise Use_Error;
                  when Ordinary_File =>
                     Delete_File (Name);
                  when Directories.Directory =>
                     declare
                        Simple : String renames Simple_Name (Directory_Entry);
                     begin
                        if Simple /= "." and then Simple /= ".." then
                           Delete_Tree (Name);
                        end if;
                     end;
               end case;
            end;
         end;
      end loop;
      End_Search (Search);
      Delete_Directory (Directory);
   end Delete_Tree;

   ------------
   -- Exists --
   ------------

   function Exists (Name : String) return Boolean is
      use type Interfaces.Unsigned_32;
      Data : aliased WIN32_FILE_ATTRIBUTE_DATA;
      --  UTF16 Length <= UTF8 Length, "+ 1" for NUL
      Buffer : Wide_String (1 .. Name'Length + 1);
      Last : Positive;
   begin
      UTF8_To_UTF16 (Name, Buffer, Last);
      Buffer (Last + 1) := Wide_Character'Val (0);
      return GetFileAttributesExW (
         Buffer (Buffer'First)'Unrestricted_Access,
         GetFileExInfoStandard,
         Data'Access) /= 0;
   end Exists;

   ---------------
   -- Extension --
   ---------------

   function Extension (Name : String) return String is
   begin
      --  First, the invalid case
      if not Is_Valid_Path_Name (Name) then
         raise Name_Error;
      else
         --  Look for first dot that is not followed by a directory separator
         for Pos in reverse Name'Range loop
            --  If a directory separator is found before a dot, there
            --  is no extension.
            case Name (Pos) is
               when '\' | '/' | ':' =>
                  return "";
               when '.' =>
                  --  We found a dot, build the return value with lower bound 1
                  declare
                     Result : String (1 .. Name'Last - Pos);
                  begin
                     Result := Name (Pos + 1 .. Name'Last);
                     return Result;
                     --  This should be done with a subtype conversion,
                     --  avoiding the unnecessary junk copy ???
                  end;
               when others =>
                  null;
            end case;
         end loop;
         --  No dot were found, there is no extension
         return "";
      end if;
   end Extension;

   --------------
   -- Finalize --
   --------------

   procedure Finalize (Search : in out Search_Type) is
      use type Interfaces.Unsigned_32;
   begin
      if Search.Handle /= INVALID_HANDLE_VALUE then
         --  Close the directory, if one is open
         FindClose (Search.Handle);
         Search.Handle := INVALID_HANDLE_VALUE;
         --  Free search path
         Free (Search.Path);
      end if;
   end Finalize;

   ---------------
   -- Full_Name --
   ---------------

   function Full_Name (Name : String) return String is
      use type Interfaces.Unsigned_32;
      --  UTF16 Length <= UTF8 Length, "+ 1" for NUL
      Buffer : Wide_String (1 .. Name'Length + 1);
      Last : Natural;
      Long : Wide_String (1 .. MAX_PATH);
      Long_Last : Natural;
      Full : Wide_String (1 .. MAX_PATH);
      Full_Last : Natural;
      Result : String (1 .. MAX_PATH * 6);
      Result_Last : Natural;
   begin
      if not Is_Valid_Path_Name (Name) then
         raise Name_Error;
      else
         --  convert character code
         UTF8_To_UTF16 (Name, Buffer, Last);
         Buffer (Last + 1) := Wide_Character'Val (0);
         --  Expand 8.3 filename to long filename
         Long_Last := Natural (GetLongPathNameW (
            Buffer (Buffer'First)'Unrestricted_Access,
            Long (Long'First)'Unrestricted_Access, MAX_PATH));
         if Long_Last = 0 then
            Long (1 .. Last + 1) := Buffer (1 .. Last + 1);
            Long_Last := Last;
         end if;
         --  Expand directories
         Full_Last := Natural (GetFullPathNameW (
            Long (Long'First)'Unrestricted_Access,
            MAX_PATH, Full (Full'First)'Unrestricted_Access, null));
         if Full_Last = 0 then
            Full (1 .. Long_Last + 1) := Long (1 .. Long_Last + 1);
            Full_Last := Long_Last;
         end if;
         --  Restore character code
         UTF16_To_UTF8 (Full (1 .. Full_Last), Result, Result_Last);
         --  Drive letter to upper case
         if Result_Last >= 2
            and then Result (2) = ':'
            and then Result (1) in 'a' .. 'z'
         then
            Result (1) := Character'Val (Character'Pos
               (Result (1)) - (Character'Pos ('a') - Character'Pos ('A')));
         end if;
         return Result (1 .. Result_Last);
      end if;
   end Full_Name;

   function Full_Name (Directory_Entry : Directory_Entry_Type) return String is
   begin
      --  First, the invalid case
      if not Directory_Entry.Is_Valid then
         raise Status_Error;
      else
         return Compose (Directory_Entry.Search.Path.all,
            Directory_Entry.Simple_Name (1 .. Directory_Entry.Simple_Length));
      end if;
   end Full_Name;

   --------------------
   -- Get_Next_Entry --
   --------------------

   procedure Get_Next_Entry
     (Search          : in out Search_Type;
      Directory_Entry : out Directory_Entry_Type)
   is
      use type Interfaces.Unsigned_32;
   begin
      --  First, the invalid case
      --  It is an error if no valid entry is found
      if Search.Handle = INVALID_HANDLE_VALUE or else not Search.Is_Valid then
         raise Status_Error;
      else
         --  Reset Entry_Fatched and return the entry
         Directory_Entry.Search := Search'Unchecked_Access;
         Directory_Entry.Is_Valid := True;
         --  Name
         declare
            Name_Length : constant Natural := Natural (wcslen
               (Search.Data.FileName (1)'Unrestricted_Access));
         begin
            UTF16_To_UTF8 (Search.Data.FileName (1 .. Name_Length),
               Directory_Entry.Simple_Name, Directory_Entry.Simple_Length);
         end;
         --  Kind
         Directory_Entry.Kind := To_File_Kind (Search.Data.FileAttributes);
         --  Size
         Directory_Entry.Size := File_Size (To_Unsigned_64 ((
            Low => Search.Data.FileSizeLow,
            High => Search.Data.FileSizeHigh)));
         --  Time
         declare
            Local_Time : aliased FILETIME;
         begin
            FileTimeToLocalFileTime
               (Search.Data.LastWriteTime'Access, Local_Time'Access);
            Directory_Entry.Modification_Time := To_Time (Local_Time);
         end;
         --  Search Next
         loop
            if FindNextFileW (Search.Handle, Search.Data'Access) = 0 then
               --  End
               Search.Is_Valid := False;
               exit;
            end if;
            if Search.Filter (To_File_Kind (Search.Data.FileAttributes)) then
               --  Next entry found
               exit;
            end if;
         end loop;
      end if;
   end Get_Next_Entry;

   ----------
   -- Kind --
   ----------

   function Kind (Name : String) return File_Kind is
      use type Interfaces.Unsigned_32;
      Data : aliased WIN32_FILE_ATTRIBUTE_DATA;
      --  UTF16 Length <= UTF8 Length, "+ 1" for NUL
      Buffer : Wide_String (1 .. Name'Length + 1);
      Last : Positive;
   begin
      UTF8_To_UTF16 (Name, Buffer, Last);
      Buffer (Last + 1) := Wide_Character'Val (0);
      if GetFileAttributesExW (
         Buffer (Buffer'First)'Unrestricted_Access,
         GetFileExInfoStandard,
         Data'Access) = 0
      then
         raise Name_Error;
      else
         return To_File_Kind (Data.FileAttributes);
      end if;
   end Kind;

   function Kind (Directory_Entry : Directory_Entry_Type) return File_Kind is
   begin
      --  First, the invalid case
      if not Directory_Entry.Is_Valid then
         raise Status_Error;
      else
         --  The value to return has already be computed
         return Directory_Entry.Kind;
      end if;
   end Kind;

   -----------------------
   -- Modification_Time --
   -----------------------

   function Modification_Time (Name : String) return Ada.Calendar.Time is
      use type Interfaces.Unsigned_32;
      Data : aliased WIN32_FILE_ATTRIBUTE_DATA;
      --  UTF16 Length <= UTF8 Length, "+ 1" for NUL
      Buffer : Wide_String (1 .. Name'Length + 1);
      Last : Positive;
   begin
      UTF8_To_UTF16 (Name, Buffer, Last);
      Buffer (Last + 1) := Wide_Character'Val (0);
      if GetFileAttributesExW (
         Buffer (Buffer'First)'Unrestricted_Access,
         GetFileExInfoStandard,
         Data'Access) = 0
      then
         raise Name_Error;
      else
         declare
            Local_Time : aliased FILETIME;
         begin
            FileTimeToLocalFileTime
               (Data.LastWriteTime'Access, Local_Time'Access);
            return To_Time (Local_Time);
         end;
      end if;
   end Modification_Time;

   function Modification_Time
     (Directory_Entry : Directory_Entry_Type) return Ada.Calendar.Time is
   begin
      --  First, the invalid case
      if not Directory_Entry.Is_Valid then
         raise Status_Error;
      else
         --  The value to return has already be computed
         return Directory_Entry.Modification_Time;
      end if;
   end Modification_Time;

   ------------------
   -- More_Entries --
   ------------------

   function More_Entries (Search : Search_Type) return Boolean is
      use type Interfaces.Unsigned_32;
   begin
      return Search.Handle /= INVALID_HANDLE_VALUE
         and then Search.Is_Valid;
   end More_Entries;

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

   procedure Rename (Old_Name, New_Name : String) is
      use type Interfaces.Unsigned_32;
      --  UTF16 Length <= UTF8 Length, "+ 1" for NUL
      Old_Buffer : Wide_String (1 .. Old_Name'Length + 1);
      Old_Last : Positive;
      New_Buffer : Wide_String (1 .. New_Name'Length + 1);
      New_Last : Positive;
   begin
      UTF8_To_UTF16 (Old_Name, Old_Buffer, Old_Last);
      Old_Buffer (Old_Last + 1) := Wide_Character'Val (0);
      UTF8_To_UTF16 (New_Name, New_Buffer, New_Last);
      New_Buffer (New_Last + 1) := Wide_Character'Val (0);
      if MoveFileExW (Old_Buffer (Old_Buffer'First)'Unrestricted_Access,
         New_Buffer (New_Buffer'First)'Unrestricted_Access, 0) = 0
      then
         case GetLastError is
            when ERROR_FILE_NOT_FOUND | ERROR_PATH_NOT_FOUND =>
               raise Name_Error;
            when others =>
               raise Use_Error;
         end case;
      end if;
   end Rename;

   -------------------
   -- Set_Directory --
   -------------------

   procedure Set_Directory (Directory : String) is
      use type Interfaces.Unsigned_32;
      --  UTF16 Length <= UTF8 Length, "+ 1" for NUL
      Buffer : Wide_String (1 .. Directory'Length + 1);
      Last : Positive;
   begin
      UTF8_To_UTF16 (Directory, Buffer, Last);
      Buffer (Last + 1) := Wide_Character'Val (0);
      if SetCurrentDirectoryW
         (Buffer (Buffer'First)'Unrestricted_Access) = 0
      then
         case GetLastError is
            when ERROR_FILE_NOT_FOUND | ERROR_PATH_NOT_FOUND =>
               raise Name_Error;
            when others =>
               raise Use_Error;
         end case;
      end if;
   end Set_Directory;

   -----------------
   -- Simple_Name --
   -----------------

   function Simple_Name (Name : String) return String is
   begin
      --  First, the invalid case
      if not Is_Valid_Path_Name (Name) then
         raise Name_Error;
      else
         --  Name as UTF-8
         for I in reverse Name'Range loop
            case Name (I) is
               when ':' | '\' | '/' =>
                  return Name (I + 1 .. Name'Last);
               when others =>
                  null;
            end case;
         end loop;
         return Name;
      end if;
   end Simple_Name;

   function Simple_Name
     (Directory_Entry : Directory_Entry_Type) return String is
   begin
      --  First, the invalid case
      if not Directory_Entry.Is_Valid then
         raise Status_Error;
      else
         --  The value to return has already be computed
         return Directory_Entry.Simple_Name
            (1 .. Directory_Entry.Simple_Length);
      end if;
   end Simple_Name;

   ----------
   -- Size --
   ----------

   function Size (Name : String) return File_Size is
      use type Interfaces.Unsigned_32;
      Data : aliased WIN32_FILE_ATTRIBUTE_DATA;
      --  UTF16 Length <= UTF8 Length, "+ 1" for NUL
      Buffer : Wide_String (1 .. Name'Length + 1);
      Last : Positive;
   begin
      UTF8_To_UTF16 (Name, Buffer, Last);
      Buffer (Last + 1) := Wide_Character'Val (0);
      if GetFileAttributesExW (
         Buffer (Buffer'First)'Unrestricted_Access,
         GetFileExInfoStandard,
         Data'Access) = 0
      then
         raise Name_Error;
      else
         if To_File_Kind (Data.FileAttributes) /= Ordinary_File then
            raise Name_Error;
         end if;
         return File_Size (To_Unsigned_64
            ((Low => Data.FileSizeLow, High => Data.FileSizeHigh)));
      end if;
   end Size;

   function Size (Directory_Entry : Directory_Entry_Type) return File_Size is
   begin
      --  First, the invalid case
      if not Directory_Entry.Is_Valid
         or else Directory_Entry.Kind /= Ordinary_File
      then
         raise Status_Error;
      else
         --  The value to return has already be computed
         return Directory_Entry.Size;
      end if;
   end Size;

   ------------------
   -- Start_Search --
   ------------------

   procedure Start_Search
     (Search    : in out Search_Type;
      Directory : String;
      Pattern   : String;
      Filter    : Filter_Type := (others => True))
   is
      use type Interfaces.Unsigned_32;
   begin
      --  If needed, finalize Search
      Finalize (Search);
      --  Find first
      declare
         Wildcard : String (1 .. Directory'Length + Pattern'Length + 1);
         Wildcard_Last : Natural;
         --  UTF16 Length <= UTF8 Length, "+ 1" for NUL
         Buffer : Wide_String (1 .. Wildcard'Length + 1);
         Last : Positive;
      begin
         --  Compose wildcard
         Wildcard (1 .. Directory'Length) := Directory;
         case Directory (Directory'Last) is
            when '\' | '/' | ':' =>
               Wildcard (Directory'Length + 1 .. Wildcard'Last - 1) := Pattern;
               Wildcard_Last := Wildcard'Last - 1;
            when others =>
               Wildcard (Directory'Length + 1) := '\';
               Wildcard (Directory'Length + 2 .. Wildcard'Last) := Pattern;
               Wildcard_Last := Wildcard'Last;
         end case;
         --  Convert character code
         UTF8_To_UTF16 (Wildcard (1 .. Wildcard_Last), Buffer, Last);
         Buffer (Last + 1) := Wide_Character'Val (0);
         --  Start search
         Search.Handle := FindFirstFileW (
            Buffer (Buffer'First)'Unrestricted_Access,
            Search.Data'Access);
      end;
      --  Handling result
      if Search.Handle = INVALID_HANDLE_VALUE then
         case GetLastError is
            when ERROR_FILE_NOT_FOUND | ERROR_NO_MORE_FILES =>
               --  Simply, no files match the pattern.
               Search.Is_Valid := False;
            when others =>
               --  Error by other reason, like invalid path.
               raise Name_Error;
         end case;
      else
         Search.Path := new String'(Directory);
         Search.Filter := Filter;
         Search.Is_Valid := True;
         while not Filter (To_File_Kind (Search.Data.FileAttributes)) loop
            if FindNextFileW (Search.Handle, Search.Data'Access) = 0 then
               Search.Is_Valid := False;
               exit;
            end if;
         end loop;
      end if;
   end Start_Search;

   ------------------
   -- To_File_Kind --
   ------------------

   function To_File_Kind (Attribute : Interfaces.Unsigned_32)
      return File_Kind
   is
      use type Interfaces.Unsigned_32;
   begin
      if (FILE_ATTRIBUTE_DIRECTORY and Attribute) /= 0 then
         return Directory;
      elsif (FILE_ATTRIBUTE_DEVICE and Attribute) /= 0 then
         return Special_File;
      else
         return Ordinary_File;
      end if;
   end To_File_Kind;

   -------------
   -- To_Time --
   -------------

   function To_Time (Time : FILETIME) return Ada.Calendar.Time is
      Detail : aliased SYSTEMTIME;
   begin
      FileTimeToSystemTime (Time'Unrestricted_Access, Detail'Access);
      return Ada.Calendar.Time_Of (
         Ada.Calendar.Year_Number (Detail.Year),
         Ada.Calendar.Month_Number (Detail.Month),
         Ada.Calendar.Day_Number (Detail.Day),
         (Duration (Detail.Hour) * 60 + Duration (Detail.Minute)) * 60 +
         Duration (Detail.Second));
   end To_Time;

   -------------------
   -- UTF16_To_UTF8 --
   -------------------

   procedure UTF16_To_UTF8 (Source : in Wide_String;
      Dest : out String; Last : out Natural)
   is
      pragma Suppress (Index_Check);
   begin
      Last := Dest'First - 1 + Natural (WideCharToMultiByte (CP_UTF8, 0,
         Source (Source'First)'Unrestricted_Access, Source'Length,
         Dest (Dest'First)'Unrestricted_Access, Dest'Length,
         DefaultChar => null, UsedDefaultChar => null));
   end UTF16_To_UTF8;

   -------------------
   -- UTF8_To_UTF16 --
   -------------------

   procedure UTF8_To_UTF16 (Source : in String;
      Dest : out Wide_String; Last : out Natural)
   is
      pragma Suppress (Index_Check);
   begin
      Last := Dest'First - 1 + Natural (MultiByteToWideChar (CP_UTF8, 0,
         Source (Source'First)'Unrestricted_Access, Source'Length,
         Dest (Dest'First)'Unrestricted_Access, Dest'Length));
   end UTF8_To_UTF16;

end Ada.Directories;
------------------------------------------------------------------------------
--                                                                          --
--                         GNAT RUN-TIME COMPONENTS                         --
--                                                                          --
--                      A D A . D I R E C T O R I E S                       --
--                                                                          --
--                                 S p e c                                  --
--                            (Windows Version)                             --
--                                                                          --
--          Copyright (C) 2004-2005, Free Software Foundation, Inc.         --
--                                                                          --
-- This specification is derived for use with GNAT from AI-00248,  which is --
-- expected to be a part of a future expected revised Ada Reference Manual. --
-- The copyright notice above, and the license provisions that follow apply --
-- solely to the  contents of the part following the private keyword.       --
--                                                                          --
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
-- for  more details.  You should have  received  a copy of the GNU General --
-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
-- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
-- Boston, MA 02110-1301, USA.                                              --
--                                                                          --
-- As a special exception,  if other files  instantiate  generics from this --
-- unit, or you link  this unit with other files  to produce an executable, --
-- this  unit  does not  by itself cause  the resulting  executable  to  be --
-- covered  by the  GNU  General  Public  License.  This exception does not --
-- however invalidate  any other reasons why  the executable file  might be --
-- covered by the  GNU Public License.                                      --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------

--  Ada 2005: Implementation of Ada.Directories (AI95-00248). Note that this
--  unit is available without -gnat05. That seems reasonable, since you only
--  get it if you explicitly ask for it.

--  External files may be classified as directories, special files, or ordinary
--  files. A directory is an external file that is a container for files on
--  the target system. A special file is an external file that cannot be
--  created or read by a predefined Ada Input-Output package. External files
--  that are not special files or directories are called ordinary files.

--  A file name is a string identifying an external file. Similarly, a
--  directory name is a string identifying a directory. The interpretation of
--  file names and directory names is implementation-defined.

--  The full name of an external file is a full specification of the name of
--  the file. If the external environment allows alternative specifications of
--  the name (for example, abbreviations), the full name should not use such
--  alternatives. A full name typically will include the names of all of
--  directories that contain the item. The simple name of an external file is
--  the name of the item, not including any containing directory names. Unless
--  otherwise specified, a file name or directory name parameter to a
--  predefined Ada input-output subprogram can be a full name, a simple name,
--  or any other form of name supported by the implementation.

--  The default directory is the directory that is used if a directory or
--  file name is not a full name (that is, when the name does not fully
--  identify all of the containing directories).

--  A directory entry is a single item in a directory, identifying a single
--  external file (including directories and special files).

--  For each function that returns a string, the lower bound of the returned
--  value is 1.

--  This is the Windows version of this package

with Ada.Calendar;
with Ada.Finalization;
with Ada.IO_Exceptions;
private with Interfaces;
private with Ada.Unchecked_Deallocation;

package Ada.Directories is
   pragma Ada_05;
   --  To be removed later ???

   -----------------------------------
   -- Directory and File Operations --
   -----------------------------------

   function Current_Directory return String;
   --  Returns the full directory name for the current default directory. The
   --  name returned shall be suitable for a future call to Set_Directory.
   --  The exception Use_Error is propagated if a default directory is not
   --  supported by the external environment.

   procedure Set_Directory (Directory : String);
   --  Sets the current default directory. The exception Name_Error is
   --  propagated if the string given as Directory does not identify an
   --  existing directory. The exception Use_Error is propagated if the
   --  external environment does not support making Directory (in the absence
   --  of Name_Error) a default directory.

   procedure Create_Directory
     (New_Directory : String;
      Form          : String := "");
   --  Creates a directory with name New_Directory. The Form parameter can be
   --  used to give system-dependent characteristics of the directory; the
   --  interpretation of the Form parameter is implementation-defined. A null
   --  string for Form specifies the use of the default options of the
   --  implementation of the new directory. The exception Name_Error is
   --  propagated if the string given as New_Directory does not allow the
   --  identification of a directory. The exception Use_Error is propagated if
   --  the external environment does not support the creation of a directory
   --  with the given name (in the absence of Name_Error) and form.

   procedure Delete_Directory (Directory : String);
   --  Deletes an existing empty directory with name Directory. The exception
   --  Name_Error is propagated if the string given as Directory does not
   --  identify an existing directory. The exception Use_Error is propagated
   --  if the external environment does not support the deletion of the
   --  directory (or some portion of its contents) with the given name (in the
   --  absence of Name_Error).

   procedure Create_Path
     (New_Directory : String;
      Form          : String := "");
   --  Creates zero or more directories with name New_Directory. Each
   --  non-existent directory named by New_Directory is created. For example,
   --  on a typical Unix system, Create_Path ("/usr/me/my"); would create
   --  directory "me" in directory "usr", then create directory "my" in
   --  directory "me". The Form can be used to give system-dependent
   --  characteristics of the directory; the interpretation of the Form
   --  parameter is implementation-defined. A null string for Form specifies
   --  the use of the default options of the implementation of the new
   --  directory. The exception Name_Error is propagated if the string given
   --  as New_Directory does not allow the identification of any directory.
   --  The exception Use_Error is propagated if the external environment does
   --  not support the creation of any directories with the given name (in the
   --  absence of Name_Error) and form.

   procedure Delete_Tree (Directory : String);
   --  Deletes an existing directory with name Directory. The directory and
   --  all of its contents (possibly including other directories) are deleted.
   --  The exception Name_Error is propagated if the string given as Directory
   --  does not identify an existing directory. The exception Use_Error is
   --  propagated if the external environment does not support the deletion of
   --  the directory or some portion of its contents with the given name (in
   --  the absence of Name_Error). If Use_Error is propagated, it is
   --  unspecified if a portion of the contents of the directory are deleted.

   procedure Delete_File (Name : String);
   --  Deletes an existing ordinary or special file with Name. The exception
   --  Name_Error is propagated if the string given as Name does not identify
   --  an existing ordinary or special external file. The exception Use_Error
   --  is propagated if the external environment does not support the deletion
   --  of the file with the given name (in the absence of Name_Error).

   procedure Rename (Old_Name, New_Name : String);
   --  Renames an existing external file (including directories) with Old_Name
   --  to New_Name. The exception Name_Error is propagated if the string given
   --  as Old_Name does not identify an existing external file. The exception
   --  Use_Error is propagated if the external environment does not support the
   --  renaming of the file with the given name (in the absence of Name_Error).
   --  In particular, Use_Error is propagated if a file or directory already
   --  exists with New_Name.

   procedure Copy_File
     (Source_Name   : String;
      Target_Name   : String;
      Form          : String := "");
   --  Copies the contents of the existing external file with Source_Name
   --  to Target_Name. The resulting external file is a duplicate of the source
   --  external file. The Form can be used to give system-dependent
   --  characteristics of the resulting external file; the interpretation of
   --  the Form parameter is implementation-defined. Exception Name_Error is
   --  propagated if the string given as Source_Name does not identify an
   --  existing external ordinary or special file or if the string given as
   --  Target_Name does not allow the identification of an external file.
   --  The exception Use_Error is propagated if the external environment does
   --  not support the creating of the file with the name given by Target_Name
   --  and form given by Form, or copying of the file with the name given by
   --  Source_Name (in the absence of Name_Error).

   ----------------------------------------
   -- File and directory name operations --
   ----------------------------------------

   function Full_Name (Name : String) return String;
   --  Returns the full name corresponding to the file name specified by Name.
   --  The exception Name_Error is propagated if the string given as Name does
   --  not allow the identification of an external file (including directories
   --  and special files).

   function Simple_Name (Name : String) return String;
   --  Returns the simple name portion of the file name specified by Name. The
   --  exception Name_Error is propagated if the string given as Name does not
   --  allow the identification of an external file (including directories and
   --  special files).

   function Containing_Directory (Name : String) return String;
   --  Returns the name of the containing directory of the external file
   --  (including directories) identified by Name. If more than one directory
   --  can contain Name, the directory name returned is implementation-defined.
   --  The exception Name_Error is propagated if the string given as Name does
   --  not allow the identification of an external file. The exception
   --  Use_Error is propagated if the external file does not have a containing
   --  directory.

   function Extension (Name : String) return String;
   --  Returns the extension name corresponding to Name. The extension name is
   --  a portion of a simple name (not including any separator characters),
   --  typically used to identify the file class. If the external environment
   --  does not have extension names, then the null string is returned.
   --  The exception Name_Error is propagated if the string given as Name does
   --  not allow the identification of an external file.

   function Base_Name (Name : String) return String;
   --  Returns the base name corresponding to Name. The base name is the
   --  remainder of a simple name after removing any extension and extension
   --  separators. The exception Name_Error is propagated if the string given
   --  as Name does not allow the identification of an external file
   --  (including directories and special files).

   function Compose
     (Containing_Directory : String := "";
      Name                 : String;
      Extension            : String := "") return String;
   --  Returns the name of the external file with the specified
   --  Containing_Directory, Name, and Extension. If Extension is the null
   --  string, then Name is interpreted as a simple name; otherwise Name is
   --  interpreted as a base name. The exception Name_Error is propagated if
   --  the string given as Containing_Directory is not null and does not allow
   --  the identification of a directory, or if the string given as Extension
   --  is not null and is not a possible extension, or if the string given as
   --  Name is not a possible simple name (if Extension is null) or base name
   --  (if Extension is non-null).

   --------------------------------
   -- File and directory queries --
   --------------------------------

   type File_Kind is (Directory, Ordinary_File, Special_File);
   --  The type File_Kind represents the kind of file represented by an
   --  external file or directory.

   type File_Size is range 0 .. Long_Long_Integer'Last;
   --  The type File_Size represents the size of an external file

   function Exists (Name : String) return Boolean;
   --  Returns True if external file represented by Name exists, and False
   --  otherwise. The exception Name_Error is propagated if the string given as
   --  Name does not allow the identification of an external file (including
   --  directories and special files).

   function Kind (Name : String) return File_Kind;
   --  Returns the kind of external file represented by Name. The exception
   --  Name_Error is propagated if the string given as Name does not allow the
   --  identification of an existing external file.

   function Size (Name : String) return File_Size;
   --  Returns the size of the external file represented by Name. The size of
   --  an external file is the number of stream elements contained in the file.
   --  If the external file is discontiguous (not all elements exist), the
   --  result is implementation-defined. If the external file is not an
   --  ordinary file, the result is implementation-defined. The exception
   --  Name_Error is propagated if the string given as Name does not allow the
   --  identification of an existing external file. The exception
   --  Constraint_Error is propagated if the file size is not a value of type
   --  File_Size.

   function Modification_Time (Name : String) return Ada.Calendar.Time;
   --  Returns the time that the external file represented by Name was most
   --  recently modified. If the external file is not an ordinary file, the
   --  result is implementation-defined. The exception Name_Error is propagated
   --  if the string given as Name does not allow the identification of an
   --  existing external file. The exception Use_Error is propagated if the
   --  external environment does not support the reading the modification time
   --  of the file with the name given by Name (in the absence of Name_Error).

   -------------------------
   -- Directory Searching --
   -------------------------

   type Directory_Entry_Type is limited private;
   --  The type Directory_Entry_Type represents a single item in a directory.
   --  These items can only be created by the Get_Next_Entry procedure in this
   --  package. Information about the item can be obtained from the functions
   --  declared in this package. A default initialized object of this type is
   --  invalid; objects returned from Get_Next_Entry are valid.

   type Filter_Type is array (File_Kind) of Boolean;
   --  The type Filter_Type specifies which directory entries are provided from
   --  a search operation. If the Directory component is True, directory
   --  entries representing directories are provided. If the Ordinary_File
   --  component is True, directory entries representing ordinary files are
   --  provided. If the Special_File component is True, directory entries
   --  representing special files are provided.

   type Search_Type is limited private;
   --  The type Search_Type contains the state of a directory search. A
   --  default-initialized Search_Type object has no entries available
   --  (More_Entries returns False).

   procedure Start_Search
     (Search    : in out Search_Type;
      Directory : String;
      Pattern   : String;
      Filter    : Filter_Type := (others => True));
   --  Starts a search in the directory entry in the directory named by
   --  Directory for entries matching Pattern. Pattern represents a file name
   --  matching pattern. If Pattern is null, all items in the directory are
   --  matched; otherwise, the interpretation of Pattern is implementation-
   --  defined. Only items which match Filter will be returned. After a
   --  successful call on Start_Search, the object Search may have entries
   --  available, but it may have no entries available if no files or
   --  directories match Pattern and Filter. The exception Name_Error is
   --  propagated if the string given by Directory does not identify an
   --  existing directory, or if Pattern does not allow the identification of
   --  any possible external file or directory. The exception Use_Error is
   --  propagated if the external environment does not support the searching
   --  of the directory with the given name (in the absence of Name_Error).

   procedure End_Search (Search : in out Search_Type);
   --  Ends the search represented by Search. After a successful call on
   --  End_Search, the object Search will have no entries available. Note
   --  that is is not necessary to call End_Search if the call to Start_Search
   --  was unsuccessful and raised an exception (but it is harmless to make
   --  the call in this case)>

   function More_Entries (Search : Search_Type) return Boolean;
   --  Returns True if more entries are available to be returned by a call
   --  to Get_Next_Entry for the specified search object, and False otherwise.

   procedure Get_Next_Entry
     (Search          : in out Search_Type;
      Directory_Entry : out Directory_Entry_Type);
   --  Returns the next Directory_Entry for the search described by Search that
   --  matches the pattern and filter. If no further matches are available,
   --  Status_Error is raised. It is implementation-defined as to whether the
   --  results returned by this routine are altered if the contents of the
   --  directory are altered while the Search object is valid (for example, by
   --  another program). The exception Use_Error is propagated if the external
   --  environment does not support continued searching of the directory
   --  represented by Search.

   -------------------------------------
   -- Operations on Directory Entries --
   -------------------------------------

   function Simple_Name (Directory_Entry : Directory_Entry_Type) return String;
   --  Returns the simple external name of the external file (including
   --  directories) represented by Directory_Entry. The format of the name
   --  returned is implementation-defined. The exception Status_Error is
   --  propagated if Directory_Entry is invalid.

   function Full_Name (Directory_Entry : Directory_Entry_Type) return String;
   --  Returns the full external name of the external file (including
   --  directories) represented by Directory_Entry. The format of the name
   --  returned is implementation-defined. The exception Status_Error is
   --  propagated if Directory_Entry is invalid.

   function Kind (Directory_Entry : Directory_Entry_Type) return File_Kind;
   --  Returns the kind of external file represented by Directory_Entry. The
   --  exception Status_Error is propagated if Directory_Entry is invalid.

   function Size (Directory_Entry : Directory_Entry_Type) return File_Size;
   --  Returns the size of the external file represented by Directory_Entry.
   --  The size of an external file is the number of stream elements contained
   --  in the file. If the external file is discontiguous (not all elements
   --  exist), the result is implementation-defined. If the external file
   --  represented by Directory_Entry is not an ordinary file, the result is
   --  implementation-defined. The exception Status_Error is propagated if
   --  Directory_Entry is invalid. The exception Constraint_Error is propagated
   --  if the file size is not a value of type File_Size.

   function Modification_Time
     (Directory_Entry : Directory_Entry_Type) return Ada.Calendar.Time;
   --  Returns the time that the external file represented by Directory_Entry
   --  was most recently modified. If the external file represented by
   --  Directory_Entry is not an ordinary file, the result is
   --  implementation-defined. The exception Status_Error is propagated if
   --  Directory_Entry is invalid. The exception Use_Error is propagated if
   --  the external environment does not support the reading the modification
   --  time of the file represented by Directory_Entry.

   ----------------
   -- Exceptions --
   ----------------

   Status_Error : exception renames Ada.IO_Exceptions.Status_Error;
   Name_Error   : exception renames Ada.IO_Exceptions.Name_Error;
   Use_Error    : exception renames Ada.IO_Exceptions.Use_Error;
   Device_Error : exception renames Ada.IO_Exceptions.Device_Error;

private

   --  Windows API

   type DBCS_String is new String;

   MAX_PATH : constant := 260;  --  includes last NUL

   type FILETIME is record
      LowDateTime  : Interfaces.Unsigned_32;
      HighDateTime : Interfaces.Unsigned_32;
   end record;
   pragma Convention (C, FILETIME);

   FILE_ATTRIBUTE_READONLY            : constant := 16#00000001#;
   FILE_ATTRIBUTE_HIDDEN              : constant := 16#00000002#;
   FILE_ATTRIBUTE_SYSTEM              : constant := 16#00000004#;
   FILE_ATTRIBUTE_DIRECTORY           : constant := 16#00000010#;
   FILE_ATTRIBUTE_ARCHIVE             : constant := 16#00000020#;
   FILE_ATTRIBUTE_DEVICE              : constant := 16#00000040#;
   FILE_ATTRIBUTE_NORMAL              : constant := 16#00000080#;
   FILE_ATTRIBUTE_TEMPORARY           : constant := 16#00000100#;
   FILE_ATTRIBUTE_SPARSE_FILE         : constant := 16#00000200#;
   FILE_ATTRIBUTE_REPARSE_POINT       : constant := 16#00000400#;
   FILE_ATTRIBUTE_COMPRESSED          : constant := 16#00000800#;
   FILE_ATTRIBUTE_OFFLINE             : constant := 16#00001000#;
   FILE_ATTRIBUTE_NOT_CONTENT_INDEXED : constant := 16#00002000#;
   FILE_ATTRIBUTE_ENCRYPTED           : constant := 16#00004000#;
   FILE_ATTRIBUTE_VALID_FLAGS         : constant := 16#00007fb7#;
   FILE_ATTRIBUTE_VALID_SET_FLAGS     : constant := 16#000031a7#;

   type Character_Access is access all Character;
   type Wide_Character_Access is access all Wide_Character;

   function GetFullPathNameA (
     FileName : access constant Character;
     BufferLength : Interfaces.Unsigned_32;
     Buffer : access constant Character;
     FilePart : access Character_Access) return Interfaces.Unsigned_32;
   function GetFullPathNameW (
     FileName : access constant Wide_Character;
     BufferLength : Interfaces.Unsigned_32;
     Buffer : access constant Wide_Character;
     FilePart : access Wide_Character_Access) return Interfaces.Unsigned_32;
   pragma Import (stdcall, GetFullPathNameA, "GetFullPathNameA");
   pragma Import (stdcall, GetFullPathNameW, "GetFullPathNameW");

   function GetLongPathNameA (
     ShortPath : access constant Character;
     LongPath : access Character;
     Buffer : Interfaces.Unsigned_32) return Interfaces.Unsigned_32;
   function GetLongPathNameW (
     ShortPath : access constant Wide_Character;
     LongPath : access Wide_Character;
     Buffer : Interfaces.Unsigned_32) return Interfaces.Unsigned_32;
   pragma Import (stdcall, GetLongPathNameA, "GetLongPathNameA");
   pragma Import (stdcall, GetLongPathNameW, "GetLongPathNameW");

   type WIN32_FIND_DATAA is record
      FileAttributes    : Interfaces.Unsigned_32;
      CreationTime      : aliased FILETIME;
      LastAccessTime    : aliased FILETIME;
      LastWriteTime     : aliased FILETIME;
      FileSizeHigh      : Interfaces.Unsigned_32;
      FileSizeLow       : Interfaces.Unsigned_32;
      Reserved0         : Interfaces.Unsigned_32;
      Reserved1         : Interfaces.Unsigned_32;
      FileName          : DBCS_String (1 .. MAX_PATH);
      AlternateFileName : DBCS_String (1 .. 14);
   end record;
   pragma Convention (C, WIN32_FIND_DATAA);

   type WIN32_FIND_DATAW is record
      FileAttributes    : Interfaces.Unsigned_32;
      CreationTime      : aliased FILETIME;
      LastAccessTime    : aliased FILETIME;
      LastWriteTime     : aliased FILETIME;
      FileSizeHigh      : Interfaces.Unsigned_32;
      FileSizeLow       : Interfaces.Unsigned_32;
      Reserved0         : Interfaces.Unsigned_32;
      Reserved1         : Interfaces.Unsigned_32;
      FileName          : Wide_String (1 .. MAX_PATH);
      AlternateFileName : Wide_String (1 .. 14);
   end record;
   pragma Convention (C, WIN32_FIND_DATAW);

   function FindFirstFileA (FileName : access constant Character;
      FindFileData : access WIN32_FIND_DATAA) return Interfaces.Unsigned_32;
   function FindFirstFileW (FileName : access constant Wide_Character;
      FindFileData : access WIN32_FIND_DATAW) return Interfaces.Unsigned_32;
   pragma Import (stdcall, FindFirstFileA, "FindFirstFileA");
   pragma Import (stdcall, FindFirstFileW, "FindFirstFileW");

   INVALID_HANDLE_VALUE : constant := Interfaces.Unsigned_32'Last;

   function FindNextFileA (FindFile : Interfaces.Unsigned_32;
      FindFileData : access WIN32_FIND_DATAA) return Interfaces.Unsigned_32;
   function FindNextFileW (FindFile : Interfaces.Unsigned_32;
      FindFileData : access WIN32_FIND_DATAW) return Interfaces.Unsigned_32;
   pragma Import (stdcall, FindNextFileA, "FindNextFileA");
   pragma Import (stdcall, FindNextFileW, "FindNextFileW");

   function FindClose (FindFile : Interfaces.Unsigned_32)
      return Interfaces.Unsigned_32;
   procedure FindClose (FindFile : Interfaces.Unsigned_32);
   pragma Import (stdcall, FindClose, "FindClose");

   type WIN32_FILE_ATTRIBUTE_DATA is record
      FileAttributes : Interfaces.Unsigned_32;
      CreationTime : aliased FILETIME;
      LastAccessTime : aliased FILETIME;
      LastWriteTime : aliased FILETIME;
      FileSizeHigh : Interfaces.Unsigned_32;
      FileSizeLow : Interfaces.Unsigned_32;
   end record;
   pragma Convention (C, WIN32_FILE_ATTRIBUTE_DATA);

   function GetFileAttributesExA (
      FileName : access Character;
      InfoLevelId : Interfaces.Unsigned_32;
      FileInformation : access WIN32_FILE_ATTRIBUTE_DATA)
      return Interfaces.Unsigned_32;
   function GetFileAttributesExW (
      FileName : access Wide_Character;
      InfoLevelId : Interfaces.Unsigned_32;
      FileInformation : access WIN32_FILE_ATTRIBUTE_DATA)
      return Interfaces.Unsigned_32;
   pragma Import (stdcall, GetFileAttributesExA, "GetFileAttributesExA");
   pragma Import (stdcall, GetFileAttributesExW, "GetFileAttributesExW");

   GetFileExInfoStandard : constant := 0;

   function GetCurrentDirectoryA (BufferLength : Interfaces.Unsigned_32;
      Buffer : access constant Character) return Interfaces.Unsigned_32;
   function GetCurrentDirectoryW (BufferLength : Interfaces.Unsigned_32;
      Buffer : access constant Wide_Character) return Interfaces.Unsigned_32;
   pragma Import (stdcall, GetCurrentDirectoryA, "GetCurrentDirectoryA");
   pragma Import (stdcall, GetCurrentDirectoryW, "GetCurrentDirectoryW");

   function SetCurrentDirectoryA (PathName : access constant Character)
      return Interfaces.Unsigned_32;
   function SetCurrentDirectoryW (PathName : access constant Wide_Character)
      return Interfaces.Unsigned_32;
   pragma Import (stdcall, SetCurrentDirectoryA, "SetCurrentDirectoryA");
   pragma Import (stdcall, SetCurrentDirectoryW, "SetCurrentDirectoryW");

   type SECURITY_ATTRIBUTES is null record; --  dummy

   function CreateDirectoryA (PathName : access constant Character;
      SecurityAttributes : access SECURITY_ATTRIBUTES)
      return Interfaces.Unsigned_32;
   function CreateDirectoryW (PathName : access constant Wide_Character;
      SecurityAttributes : access SECURITY_ATTRIBUTES)
      return Interfaces.Unsigned_32;
   pragma Import (stdcall, CreateDirectoryA, "CreateDirectoryA");
   pragma Import (stdcall, CreateDirectoryW, "CreateDirectoryW");

   function RemoveDirectoryA (PathName : access constant Character)
      return Interfaces.Unsigned_32;
   function RemoveDirectoryW (PathName : access constant Wide_Character)
      return Interfaces.Unsigned_32;
   pragma Import (stdcall, RemoveDirectoryA, "RemoveDirectoryA");
   pragma Import (stdcall, RemoveDirectoryW, "RemoveDirectoryW");

   function DeleteFileA (FileName : access constant Character)
      return Interfaces.Unsigned_32;
   function DeleteFileW (FileName : access constant Wide_Character)
      return Interfaces.Unsigned_32;
   pragma Import (stdcall, DeleteFileA, "DeleteFileA");
   pragma Import (stdcall, DeleteFileW, "DeleteFileW");

   function MoveFileExA (ExistingFileName : access constant Character;
      NewFileName : access constant Character;
      Flags : Interfaces.Unsigned_32) return Interfaces.Unsigned_32;
   function MoveFileExW (ExistingFileName : access constant Wide_Character;
      NewFileName : access constant Wide_Character;
      Flags : Interfaces.Unsigned_32) return Interfaces.Unsigned_32;
   pragma Import (stdcall, MoveFileExA, "MoveFileExA");
   pragma Import (stdcall, MoveFileExW, "MoveFileExW");

   function CopyFileA (ExistingFileName : access constant Character;
      NewFileName : access constant Character;
      FailIfExists : Interfaces.Unsigned_32) return Interfaces.Unsigned_32;
   function CopyFileW (ExistingFileName : access constant Wide_Character;
      NewFileName : access constant Wide_Character;
      FailIfExists : Interfaces.Unsigned_32) return Interfaces.Unsigned_32;
   pragma Import (stdcall, CopyFileA, "CopyFileA");
   pragma Import (stdcall, CopyFileW, "CopyFileW");

   function FileTimeToLocalFileTime (Time : access constant FILETIME;
      LocalTime : access FILETIME) return Interfaces.Unsigned_32;
   procedure FileTimeToLocalFileTime (Time : access constant FILETIME;
      LocalTime : access FILETIME);
   pragma Import (stdcall, FileTimeToLocalFileTime, "FileTimeToLocalFileTime");

   type SYSTEMTIME is record
      Year         : Interfaces.Unsigned_16;
      Month        : Interfaces.Unsigned_16;
      DayOfWeek    : Interfaces.Unsigned_16;
      Day          : Interfaces.Unsigned_16;
      Hour         : Interfaces.Unsigned_16;
      Minute       : Interfaces.Unsigned_16;
      Second       : Interfaces.Unsigned_16;
      Milliseconds : Interfaces.Unsigned_16;
   end record;
   pragma Convention (C, SYSTEMTIME);

   function FileTimeToSystemTime
     (File : access FILETIME;
      System : access SYSTEMTIME) return Interfaces.Unsigned_32;
   procedure FileTimeToSystemTime
     (File : access FILETIME;
      System : access SYSTEMTIME);
   pragma Import (stdcall, FileTimeToSystemTime, "FileTimeToSystemTime");

   function MultiByteToWideChar (
      CodePage : Interfaces.Unsigned_32;
      Flags : Interfaces.Unsigned_32;
      MultiByteStr : access constant Character;
      MultiByte : Interfaces.Integer_32;
      WideCharStr : access Wide_Character;
      Max : Interfaces.Integer_32) return Interfaces.Integer_32;
   pragma Import (stdcall, MultiByteToWideChar, "MultiByteToWideChar");

   function WideCharToMultiByte (
     CodePage : Interfaces.Unsigned_32;
     Flags : Interfaces.Unsigned_32;
     WideCharStr : access constant Wide_Character;
     WideChar : Interfaces.Integer_32;
     MultiByteStr : access Character;
     MultiByte : Interfaces.Integer_32;
     DefaultChar : access constant Character;
     UsedDefaultChar : access Interfaces.Unsigned_32)
     return Interfaces.Integer_32;
   pragma Import (stdcall, WideCharToMultiByte, "WideCharToMultiByte");

   CP_ACP  : constant := 0;
   CP_UTF8 : constant := 65001;

   function GetLastError return Interfaces.Unsigned_32;
   pragma Import (stdcall, GetLastError, "GetLastError");

   ERROR_FILE_NOT_FOUND : constant :=  2;
   ERROR_PATH_NOT_FOUND : constant :=  3;
   ERROR_NO_MORE_FILES  : constant := 18;
   ERROR_FILE_EXISTS    : constant := 80;

   function strlen (S : access constant Character)
      return Interfaces.Unsigned_32;
   function wcslen (S : access constant Wide_Character)
      return Interfaces.Unsigned_32;
   pragma Import (C, strlen, "strlen");
   pragma Import (C, wcslen, "wcslen");

   --  Type bodies

   type Search_Access is access all Search_Type;

   type Directory_Entry_Type is record
      Search : Search_Access;
      Is_Valid : Boolean := False;
      --  Single UTF-16 letter be encoded 6 UTF-8 bytes
      Simple_Name : String (1 .. MAX_PATH * 6);
      Simple_Length : Natural;
      Kind : File_Kind;
      Size : File_Size;
      Modification_Time : Ada.Calendar.Time;
   end record;

   type String_Access is access String;
   procedure Free is new Ada.Unchecked_Deallocation (String, String_Access);

   --  Search_Type need to be a controlled type, because it includes component
   --  of type Dir_Type (in GNAT.Directory_Operations) that need to be closed
   --  (if opened) during finalization.

   type Search_Type is new Ada.Finalization.Controlled with record
      Handle : Interfaces.Unsigned_32 := INVALID_HANDLE_VALUE;
      Path : String_Access;
      Filter : Filter_Type;
      Is_Valid : Boolean;
      Data : aliased WIN32_FIND_DATAW;
   end record;

   procedure Finalize (Search : in out Search_Type);
   --  Close the directory, if opened, and deallocate Value

   procedure End_Search (Search : in out Search_Type) renames Finalize;

end Ada.Directories;
------------------------------------------------------------------------------
--                                                                          --
--                         GNAT RUN-TIME COMPONENTS                         --
--                                                                          --
--             A D A . D I R E C T O R I E S . V A L I D I T Y              --
--                                                                          --
--                                 B o d y                                  --
--                            (Windows Version)                             --
--                                                                          --
--          Copyright (C) 2004-2005, Free Software Foundation, Inc.         --
--                                                                          --
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
-- for  more details.  You should have  received  a copy of the GNU General --
-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
-- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
-- Boston, MA 02110-1301, USA.                                              --
--                                                                          --
-- As a special exception,  if other files  instantiate  generics from this --
-- unit, or you link  this unit with other files  to produce an executable, --
-- this  unit  does not  by itself cause  the resulting  executable  to  be --
-- covered  by the  GNU  General  Public  License.  This exception does not --
-- however invalidate  any other reasons why  the executable file  might be --
-- covered by the  GNU Public License.                                      --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------

--  This is the Windows version of this package

--  with Ada.Characters.Latin_1; use Ada.Characters.Latin_1;

package body Ada.Directories.Validity is

   --  Filenames are always UTF-8
--  Invalid_Character : constant array (Character) of Boolean :=
--                       (NUL .. US | '\'       => True,
--                        '/' | ':' | '*' | '?' => True,
--                        '"' | '<' | '>' | '|' => True,
--                        DEL .. NBSP           => True,
--                        others                => False);

   ---------------------------------
   -- Is_Path_Name_Case_Sensitive --
   ---------------------------------

--  function Is_Path_Name_Case_Sensitive return Boolean is
--  begin
--    return False;
--  end Is_Path_Name_Case_Sensitive;

   ------------------------
   -- Is_Valid_Path_Name --
   ------------------------

   function Is_Valid_Path_Name (Name : String) return Boolean is
      Start : Positive := Name'First;
      Last  : Natural;
   begin
      --  A path name cannot be empty, cannot contain more than 256 characters,
      --  cannot contain invalid characters and each directory/file name need
      --  to be valid.

      if Name'Length = 0 or else Name'Length >= MAX_PATH then
         return False;
      else
         --  A drive letter may be specified at the beginning

         if Name'Length >= 2
           and then  Name (Start + 1) = ':'
           and then
            (Name (Start) in 'A' .. 'Z' or else
             Name (Start) in 'a' .. 'z')
         then
            Start := Start + 2;
         end if;

         loop
            --  Look for the start of the next directory or file name
            --  This while loop skips "\\" of UNC like "\\a\b"
            while Start <= Name'Last and then
              (Name (Start) = '\' or Name (Start) = '/')
            loop
               Start := Start + 1;
            end loop;

            --  If all directories/file names are OK, return True

            exit when Start > Name'Last;

            Last := Start;

            --  Look for the end of the directory/file name

            while Last < Name'Last loop
               exit when Name (Last + 1) = '\' or Name (Last + 1) = '/';
               Last := Last + 1;
            end loop;

            --  Check if the directory/file name is valid

            if not Is_Valid_Simple_Name (Name (Start .. Last)) then
               return False;
            end if;

            --  Move to the next name

            Start := Last + 1;
         end loop;
      end if;

      --  If Name follows the rules, it is valid

      return True;
   end Is_Valid_Path_Name;

   --------------------------
   -- Is_Valid_Simple_Name --
   --------------------------

   function Is_Valid_Simple_Name (Name : String) return Boolean is
      Only_Spaces : Boolean;
      J, Len : Positive;
   begin
      --  A file name cannot be empty, cannot contain more than 256 characters,
      --  and cannot contain invalid characters.
      if Name'Length = 0 or else Name'Length >= MAX_PATH then
         return False;
      --  Name length is OK
      else
         Only_Spaces := True;
         J := Name'First;
         while J <= Name'Last loop
--       for J in Name'Range loop
--          if Invalid_Character (Name (J)) then
--             return False;
--          elsif Name (J) /= ' ' then
--             Only_Spaces := False;
--          end if;
            --  Check not including special character and valid UTF-8 Sequence.
            case Name (J) is
               when Character'Val (0) .. Character'Val (31)
                  | '\' | '/' | ':' | '*' | '?' | '"' | '<' | '>' | '|'
                  | Character'Val (16#7f#)
                  | Character'Val (16#80#) .. Character'Val (16#bf#)
                  | Character'Val (16#fe#) .. Character'Val (16#ff#) =>
                  return False;
               when ' ' =>
                  Len := 1;
               when '!' | '#' .. ')' | '+' .. '.' | '0' .. '9' | ';' | '='
                  | '@' .. '[' | ']' .. '{' | '}' .. '~' =>
                  Only_Spaces := False;
                  Len := 1;
               when Character'Val (16#c0#) .. Character'Val (16#df#) =>
                  Only_Spaces := False;
                  Len := 2;
               when Character'Val (16#e0#) .. Character'Val (16#ef#) =>
                  Only_Spaces := False;
                  Len := 3;
               when Character'Val (16#f0#) .. Character'Val (16#f7#) =>
                  Only_Spaces := False;
                  Len := 4;
               when Character'Val (16#f8#) .. Character'Val (16#fb#) =>
                  Only_Spaces := False;
                  Len := 5;
               when Character'Val (16#fc#) .. Character'Val (16#fd#) =>
                  Only_Spaces := False;
                  Len := 6;
            end case;
            J := J + Len;
            if J > Name'Last + 1 then
               return False;
            end if;
         end loop;
         --  If no invalid chars, and not all spaces, file name is valid
         return not Only_Spaces;
      end if;
   end Is_Valid_Simple_Name;

   -------------
   -- OpenVMS --
   -------------

--  function OpenVMS return Boolean is
--  begin
--    return False;
--  end OpenVMS;

end Ada.Directories.Validity;
------------------------------------------------------------------------------
--                                                                          --
--                         GNAT RUN-TIME COMPONENTS                         --
--                                                                          --
--             A D A . D I R E C T O R I E S . V A L I D I T Y              --
--                                                                          --
--                                 S p e c                                  --
--                            (Windows Version)                             --
--                                                                          --
--          Copyright (C) 2004-2005, Free Software Foundation, Inc.         --
--                                                                          --
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
-- for  more details.  You should have  received  a copy of the GNU General --
-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
-- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
-- Boston, MA 02110-1301, USA.                                              --
--                                                                          --
-- As a special exception,  if other files  instantiate  generics from this --
-- unit, or you link  this unit with other files  to produce an executable, --
-- this  unit  does not  by itself cause  the resulting  executable  to  be --
-- covered  by the  GNU  General  Public  License.  This exception does not --
-- however invalidate  any other reasons why  the executable file  might be --
-- covered by the  GNU Public License.                                      --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------

--  This private child package is used in the body of Ada.Directories.
--  It has several bodies, for different platforms.

--  This is the Windows version of this package

private package Ada.Directories.Validity is

   function Is_Valid_Simple_Name (Name : String) return Boolean;
   --  Returns True if Name is a valid file name

   function Is_Valid_Path_Name (Name : String) return Boolean;
   --  Returns True if Name is a valid path name

--  function Is_Path_Name_Case_Sensitive return Boolean;
   Is_Path_Name_Case_Sensitive : constant Boolean := False;
   --  Returns True if file and path names are case-sensitive

--  function OpenVMS return Boolean;
   OpenVMS : constant Boolean := False;
   --  Return True when OS is OpenVMS

end Ada.Directories.Validity;
------------------------------------------------------------------------------
--                                                                          --
--                         GNAT RUN-TIME COMPONENTS                         --
--                                                                          --
--                      A D A . D I R E C T O R I E S                       --
--                                                                          --
--                                 B o d y                                  --
--                            (Windows Version)                             --
--                                                                          --
--          Copyright (C) 2004-2005, Free Software Foundation, Inc.         --
--                                                                          --
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
-- for  more details.  You should have  received  a copy of the GNU General --
-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
-- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
-- Boston, MA 02110-1301, USA.                                              --
--                                                                          --
-- As a special exception,  if other files  instantiate  generics from this --
-- unit, or you link  this unit with other files  to produce an executable, --
-- this  unit  does not  by itself cause  the resulting  executable  to  be --
-- covered  by the  GNU  General  Public  License.  This exception does not --
-- however invalidate  any other reasons why  the executable file  might be --
-- covered by the  GNU Public License.                                      --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------

--  This is the Windows version of this package

with Ada.Directories.Validity; use Ada.Directories.Validity;
with Ada.Unchecked_Conversion;
package body Ada.Directories is

   function To_File_Kind (Attribute : Interfaces.Unsigned_32) return File_Kind;

   procedure UTF8_To_DBCS (Source : in String;
      Dest : out DBCS_String; Last : out Natural);
   procedure DBCS_To_UTF8 (Source : in DBCS_String;
      Dest : out String; Last : out Natural);

   type Unsigned_64_Rec is record
      Low : Interfaces.Unsigned_32;
      High : Interfaces.Unsigned_32;
   end record;
   pragma Pack (Unsigned_64_Rec);

   function To_Unsigned_64 is new Ada.Unchecked_Conversion
      (Unsigned_64_Rec, Interfaces.Unsigned_64);

   function To_Time (Time : FILETIME) return Ada.Calendar.Time;

   ---------------
   -- Base_Name --
   ---------------

   function Base_Name (Name : String) return String is
      Simple : constant String := Simple_Name (Name);
      --  Simple'First is guaranteed to be 1
   begin
      --  Look for the last dot in the file name and return the part of the
      --  file name preceding this last dot. If the first dot is the first
      --  character of the file name, the base name is the empty string.
      for Pos in reverse Simple'Range loop
         if Simple (Pos) = '.' then
            return Simple (Simple'First .. Pos - 1);
         end if;
      end loop;
      --  If there is no dot, return the complete file name
      return Simple;
   end Base_Name;

   -------------
   -- Compose --
   -------------

   function Compose
     (Containing_Directory : String := "";
      Name                 : String;
      Extension            : String := "") return String
   is
      Result : String (1 .. Containing_Directory'Length +
                              Name'Length + Extension'Length + 2);
      Last   : Natural;
   begin
      Last := Containing_Directory'Length;
      if Last > 0 then
         Result (1 .. Last) := Containing_Directory;
         --  Add a directory separator if needed
         case Result (Last) is
            when '\' | '/' =>
               null;
            when others =>
               Last := Last + 1;
               Result (Last) := '\';
         end case;
      end if;
      --  Add the file name
      Result (Last + 1 .. Last + Name'Length) := Name;
      Last := Last + Name'Length;
      --  If extension was specified, add dot followed by this extension
      if Extension'Length /= 0 then
         Last := Last + 1;
         Result (Last) := '.';
         Result (Last + 1 .. Last + Extension'Length) := Extension;
         Last := Last + Extension'Length;
      end if;
      if not Is_Valid_Path_Name (Result (1 .. Last)) then
         raise Name_Error;
      end if;
      return Result (1 .. Last);
   end Compose;

   --------------------------
   -- Containing_Directory --
   --------------------------

   function Containing_Directory (Name : String) return String is
   begin
      --  First, the invalid case
      if not Is_Valid_Path_Name (Name) then
         raise Name_Error;
      else
         --  Get the directory name using GNAT.Directory_Operations.Dir_Name
         declare
            First : Positive := Name'First;
            Last : Natural := Name'Last;
         begin
            if First < Last and then Name (First + 1) = ':' then
               First := First + 2;
            end if;
            --  Delete Last Filename
            while Last >= First loop
               case Name (Last) is
                  when '\' | '/' | ':' =>
                     exit;
                  when others =>
                     null;
               end case;
               Last := Last - 1;
            end loop;
            --  Remove any trailing directory separator, except as the first
            --  character.
            while Last > First loop
               case Name (Last) is
                  when '\' | '/' =>
                     null;
                  when others =>
                     exit;
               end case;
               Last := Last - 1;
            end loop;
            --  Special case of current directory, identified by "."
            if First = Last and then Name (First) = '.' then
               return Current_Directory;
            else
               return Name (Name'First .. Last);
            end if;
         end;
      end if;
   end Containing_Directory;

   ---------------
   -- Copy_File --
   ---------------

   procedure Copy_File
     (Source_Name   : String;
      Target_Name   : String;
      Form          : String := "")
   is
      pragma Unreferenced (Form);
      use type Interfaces.Unsigned_32;
      Old_Buffer : DBCS_String (1 .. Source_Name'Length + 1);
      Old_Last : Positive;
      New_Buffer : DBCS_String (1 .. Target_Name'Length + 1);
      New_Last : Positive;
   begin
      UTF8_To_DBCS (Source_Name, Old_Buffer, Old_Last);
      Old_Buffer (Old_Last + 1) := Character'Val (0);
      UTF8_To_DBCS (Target_Name, New_Buffer, New_Last);
      New_Buffer (New_Last + 1) := Character'Val (0);
      --  Fail if Target_Name exists
      if CopyFileA (Old_Buffer (Old_Buffer'First)'Unrestricted_Access,
         New_Buffer (New_Buffer'First)'Unrestricted_Access, 1) = 0
      then
         case GetLastError is
            when ERROR_FILE_NOT_FOUND | ERROR_PATH_NOT_FOUND =>
               raise Name_Error;
            when others =>
               raise Use_Error;
         end case;
      end if;
   end Copy_File;

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

   procedure Create_Directory
     (New_Directory : String;
      Form          : String := "")
   is
      pragma Unreferenced (Form);
      use type Interfaces.Unsigned_32;
      --  DBCS Length <= UTF8 Length, "+ 1" for NUL
      Buffer : DBCS_String (1 .. New_Directory'Length + 1);
      Last : Positive;
   begin
      UTF8_To_DBCS (New_Directory, Buffer, Last);
      Buffer (Last + 1) := Character'Val (0);
      if CreateDirectoryA
         (Buffer (Buffer'First)'Unrestricted_Access, null) = 0
      then
         case GetLastError is
            when ERROR_FILE_NOT_FOUND | ERROR_PATH_NOT_FOUND =>
               raise Name_Error;
            when others =>
               raise Use_Error;
         end case;
      end if;
   end Create_Directory;

   -----------------
   -- Create_Path --
   -----------------

   procedure Create_Path
     (New_Directory : String;
      Form          : String := "")
   is
      pragma Unreferenced (Form);
      First : Positive;
      Created : Natural;
      Last : Positive;
      Step : Boolean;
   begin
      --  First, the invalid case
      if not Is_Valid_Path_Name (New_Directory) then
         raise Name_Error;
      else
         First := New_Directory'First;
         if First < New_Directory'Last
            and then New_Directory (First + 1) = ':'
         then
            First := First + 2;
         end if;
         --  Create, if necessary, each directory in the path
         Created := First - 1;
         for J in First .. New_Directory'Last loop
            --  Look for the end of an intermediate directory
            case New_Directory (J) is
               when '\' | '/' =>
                  Step := True;
                  Last := J - 1;
               when others =>
                  Step := J = New_Directory'Last;
                  Last := J;
            end case;
            if Step then
               --  We have found a new intermediate directory
               --  each time we find a first directory separator.
               if Created < J then
                  declare
                     Step_Dir : String renames New_Directory
                        (New_Directory'First .. Last);
                  begin
                     case Kind (Step_Dir) is
                        when Ordinary_File | Special_File =>
                           raise Use_Error;
                        when Directory =>
                           null;
                     end case;
                  exception
                     when Name_Error =>
                        Create_Directory (Step_Dir);
                  end;
               end if;
               Created := J;
            end if;
         end loop;
      end if;
   end Create_Path;

   -----------------------
   -- Current_Directory --
   -----------------------

   function Current_Directory return String is
      Buffer : DBCS_String (1 .. MAX_PATH);
      Length : constant Natural := Natural (GetCurrentDirectoryA
         (MAX_PATH, Buffer (Buffer'First)'Unrestricted_Access));
   begin
      if Length = 0 then
         raise Use_Error;
      else
         declare
            Result : String (1 .. Length * 6);
            Result_Last : Natural;
         begin
            DBCS_To_UTF8 (Buffer (1 .. Length), Result, Result_Last);
            return Result (1 .. Result_Last);
         end;
      end if;
   end Current_Directory;

   ------------------
   -- DBCS_To_UTF8 --
   ------------------

   procedure DBCS_To_UTF8 (Source : in DBCS_String;
      Dest : out String; Last : out Natural)
   is
      procedure UTF16_To_UTF8 (Source : in Wide_String;
         Dest : out String; Last : out Natural);
      procedure UTF16_To_UTF8 (Source : in Wide_String;
         Dest : out String; Last : out Natural)
      is
         pragma Suppress (Index_Check);
      begin
         Last := Dest'First - 1 + Natural (WideCharToMultiByte (CP_UTF8, 0,
            Source (Source'First)'Unrestricted_Access, Source'Length,
            Dest (Dest'First)'Unrestricted_Access, Dest'Length,
            DefaultChar => null, UsedDefaultChar => null));
      end UTF16_To_UTF8;
      pragma Suppress (Index_Check);
      Temp : Wide_String (1 .. Source'Length + 1);
      Temp_Last : Natural;
   begin
      Temp_Last := Natural (MultiByteToWideChar (CP_ACP, 0,
         Source (Source'First)'Unrestricted_Access, Source'Length,
         Temp (Temp'First)'Unrestricted_Access, Temp'Length));
      UTF16_To_UTF8 (Temp (1 .. Temp_Last), Dest, Last);
   end DBCS_To_UTF8;

   ----------------------
   -- Delete_Directory --
   ----------------------

   procedure Delete_Directory (Directory : String) is
      use type Interfaces.Unsigned_32;
      --  DBCS Length <= UTF8 Length, "+ 1" for NUL
      Buffer : DBCS_String (1 .. Directory'Length + 1);
      Last : Positive;
   begin
      UTF8_To_DBCS (Directory, Buffer, Last);
      Buffer (Last + 1) := Character'Val (0);
      if RemoveDirectoryA (Buffer (Buffer'First)'Unrestricted_Access) = 0 then
         case GetLastError is
            when ERROR_FILE_NOT_FOUND | ERROR_PATH_NOT_FOUND =>
               raise Name_Error;
            when others =>
               raise Use_Error;
         end case;
      end if;
   end Delete_Directory;

   -----------------
   -- Delete_File --
   -----------------

   procedure Delete_File (Name : String) is
      use type Interfaces.Unsigned_32;
      --  DBCS Length <= UTF8 Length, "+ 1" for NUL
      Buffer : DBCS_String (1 .. Name'Length + 1);
      Last : Positive;
   begin
      UTF8_To_DBCS (Name, Buffer, Last);
      Buffer (Last + 1) := Character'Val (0);
      if DeleteFileA (Buffer (Buffer'First)'Unrestricted_Access) = 0 then
         case GetLastError is
            when ERROR_FILE_NOT_FOUND | ERROR_PATH_NOT_FOUND =>
               raise Name_Error;
            when others =>
               raise Use_Error;
         end case;
      end if;
   end Delete_File;

   -----------------
   -- Delete_Tree --
   -----------------

   procedure Delete_Tree (Directory : String) is
      Search : Search_Type;
   begin
      Start_Search (Search, Directory, "*", (others => True));
      while More_Entries (Search) loop
         declare
            Directory_Entry : Directory_Entry_Type;
         begin
            Get_Next_Entry (Search, Directory_Entry);
            declare
               Name : String renames Full_Name (Directory_Entry);
            begin
               case Kind (Directory_Entry) is
                  when Special_File =>
                     raise Use_Error;
                  when Ordinary_File =>
                     Delete_File (Name);
                  when Directories.Directory =>
                     declare
                        Simple : String renames Simple_Name (Directory_Entry);
                     begin
                        if Simple /= "." and then Simple /= ".." then
                           Delete_Tree (Name);
                        end if;
                     end;
               end case;
            end;
         end;
      end loop;
      End_Search (Search);
      Delete_Directory (Directory);
   end Delete_Tree;

   ------------
   -- Exists --
   ------------

   function Exists (Name : String) return Boolean is
      use type Interfaces.Unsigned_32;
      Data : aliased WIN32_FILE_ATTRIBUTE_DATA;
      --  DBCS Length <= UTF8 Length, "+ 1" for NUL
      Buffer : DBCS_String (1 .. Name'Length + 1);
      Last : Positive;
   begin
      UTF8_To_DBCS (Name, Buffer, Last);
      Buffer (Last + 1) := Character'Val (0);
      return GetFileAttributesExA (
         Buffer (Buffer'First)'Unrestricted_Access,
         GetFileExInfoStandard,
         Data'Access) /= 0;
   end Exists;

   ---------------
   -- Extension --
   ---------------

   function Extension (Name : String) return String is
   begin
      --  First, the invalid case
      if not Is_Valid_Path_Name (Name) then
         raise Name_Error;
      else
         --  Look for first dot that is not followed by a directory separator
         for Pos in reverse Name'Range loop
            --  If a directory separator is found before a dot, there
            --  is no extension.
            case Name (Pos) is
               when '\' | '/' | ':' =>
                  return "";
               when '.' =>
                  --  We found a dot, build the return value with lower bound 1
                  declare
                     Result : String (1 .. Name'Last - Pos);
                  begin
                     Result := Name (Pos + 1 .. Name'Last);
                     return Result;
                     --  This should be done with a subtype conversion,
                     --  avoiding the unnecessary junk copy ???
                  end;
               when others =>
                  null;
            end case;
         end loop;
         --  No dot were found, there is no extension
         return "";
      end if;
   end Extension;

   --------------
   -- Finalize --
   --------------

   procedure Finalize (Search : in out Search_Type) is
      use type Interfaces.Unsigned_32;
   begin
      if Search.Handle /= INVALID_HANDLE_VALUE then
         --  Close the directory, if one is open
         FindClose (Search.Handle);
         Search.Handle := INVALID_HANDLE_VALUE;
         --  Free search path
         Free (Search.Path);
      end if;
   end Finalize;

   ---------------
   -- Full_Name --
   ---------------

   function Full_Name (Name : String) return String is
      use type Interfaces.Unsigned_32;
      --  DBCS Length <= UTF8 Length, "+ 1" for NUL
      Buffer : DBCS_String (1 .. Name'Length + 1);
      Last : Natural;
      Long : DBCS_String (1 .. MAX_PATH);
      Long_Last : Natural;
      Full : DBCS_String (1 .. MAX_PATH);
      Full_Last : Natural;
      Result : String (1 .. MAX_PATH * 6);
      Result_Last : Natural;
   begin
      if not Is_Valid_Path_Name (Name) then
         raise Name_Error;
      else
         --  convert character code
         UTF8_To_DBCS (Name, Buffer, Last);
         Buffer (Last + 1) := Character'Val (0);
         --  Expand 8.3 filename to long filename
         Long_Last := Natural (GetLongPathNameA (
            Buffer (Buffer'First)'Unrestricted_Access,
            Long (Long'First)'Unrestricted_Access, MAX_PATH));
         if Long_Last = 0 then
            Long (1 .. Last + 1) := Buffer (1 .. Last + 1);
            Long_Last := Last;
         end if;
         --  Expand directories
         Full_Last := Natural (GetFullPathNameA (
            Long (Long'First)'Unrestricted_Access,
            MAX_PATH, Full (Full'First)'Unrestricted_Access, null));
         if Full_Last = 0 then
            Full (1 .. Long_Last + 1) := Long (1 .. Long_Last + 1);
            Full_Last := Long_Last;
         end if;
         --  Restore character code
         DBCS_To_UTF8 (Full (1 .. Full_Last), Result, Result_Last);
         --  Drive letter to upper case
         if Result_Last >= 2
            and then Result (2) = ':'
            and then Result (1) in 'a' .. 'z'
         then
            Result (1) := Character'Val (Character'Pos
               (Result (1)) - (Character'Pos ('a') - Character'Pos ('A')));
         end if;
         return Result (1 .. Result_Last);
      end if;
   end Full_Name;

   function Full_Name (Directory_Entry : Directory_Entry_Type) return String is
   begin
      --  First, the invalid case
      if not Directory_Entry.Is_Valid then
         raise Status_Error;
      else
         return Compose (Directory_Entry.Search.Path.all,
            Directory_Entry.Simple_Name (1 .. Directory_Entry.Simple_Length));
      end if;
   end Full_Name;

   --------------------
   -- Get_Next_Entry --
   --------------------

   procedure Get_Next_Entry
     (Search          : in out Search_Type;
      Directory_Entry : out Directory_Entry_Type)
   is
      use type Interfaces.Unsigned_32;
   begin
      --  First, the invalid case
      --  It is an error if no valid entry is found
      if Search.Handle = INVALID_HANDLE_VALUE or else not Search.Is_Valid then
         raise Status_Error;
      else
         --  Reset Entry_Fatched and return the entry
         Directory_Entry.Search := Search'Unchecked_Access;
         Directory_Entry.Is_Valid := True;
         --  Name
         declare
            Name_Length : constant Natural := Natural (strlen
               (Search.Data.FileName (1)'Unrestricted_Access));
         begin
            DBCS_To_UTF8 (Search.Data.FileName (1 .. Name_Length),
               Directory_Entry.Simple_Name, Directory_Entry.Simple_Length);
         end;
         --  Kind
         Directory_Entry.Kind := To_File_Kind (Search.Data.FileAttributes);
         --  Size
         Directory_Entry.Size := File_Size (To_Unsigned_64 ((
            Low => Search.Data.FileSizeLow,
            High => Search.Data.FileSizeHigh)));
         --  Time
         declare
            Local_Time : aliased FILETIME;
         begin
            FileTimeToLocalFileTime
               (Search.Data.LastWriteTime'Access, Local_Time'Access);
            Directory_Entry.Modification_Time := To_Time (Local_Time);
         end;
         --  Search Next
         loop
            if FindNextFileA (Search.Handle, Search.Data'Access) = 0 then
               --  End
               Search.Is_Valid := False;
               exit;
            end if;
            if Search.Filter (To_File_Kind (Search.Data.FileAttributes)) then
               --  Next entry found
               exit;
            end if;
         end loop;
      end if;
   end Get_Next_Entry;

   ----------
   -- Kind --
   ----------

   function Kind (Name : String) return File_Kind is
      use type Interfaces.Unsigned_32;
      Data : aliased WIN32_FILE_ATTRIBUTE_DATA;
      --  DBCS Length <= UTF8 Length, "+ 1" for NUL
      Buffer : DBCS_String (1 .. Name'Length + 1);
      Last : Positive;
   begin
      UTF8_To_DBCS (Name, Buffer, Last);
      Buffer (Last + 1) := Character'Val (0);
      if GetFileAttributesExA (
         Buffer (Buffer'First)'Unrestricted_Access,
         GetFileExInfoStandard,
         Data'Access) = 0
      then
         raise Name_Error;
      else
         return To_File_Kind (Data.FileAttributes);
      end if;
   end Kind;

   function Kind (Directory_Entry : Directory_Entry_Type) return File_Kind is
   begin
      --  First, the invalid case
      if not Directory_Entry.Is_Valid then
         raise Status_Error;
      else
         --  The value to return has already be computed
         return Directory_Entry.Kind;
      end if;
   end Kind;

   -----------------------
   -- Modification_Time --
   -----------------------

   function Modification_Time (Name : String) return Ada.Calendar.Time is
      use type Interfaces.Unsigned_32;
      Data : aliased WIN32_FILE_ATTRIBUTE_DATA;
      --  DBCS Length <= UTF8 Length, "+ 1" for NUL
      Buffer : DBCS_String (1 .. Name'Length + 1);
      Last : Positive;
   begin
      UTF8_To_DBCS (Name, Buffer, Last);
      Buffer (Last + 1) := Character'Val (0);
      if GetFileAttributesExA (
         Buffer (Buffer'First)'Unrestricted_Access,
         GetFileExInfoStandard,
         Data'Access) = 0
      then
         raise Name_Error;
      else
         declare
            Local_Time : aliased FILETIME;
         begin
            FileTimeToLocalFileTime
               (Data.LastWriteTime'Access, Local_Time'Access);
            return To_Time (Local_Time);
         end;
      end if;
   end Modification_Time;

   function Modification_Time
     (Directory_Entry : Directory_Entry_Type) return Ada.Calendar.Time is
   begin
      --  First, the invalid case
      if not Directory_Entry.Is_Valid then
         raise Status_Error;
      else
         --  The value to return has already be computed
         return Directory_Entry.Modification_Time;
      end if;
   end Modification_Time;

   ------------------
   -- More_Entries --
   ------------------

   function More_Entries (Search : Search_Type) return Boolean is
      use type Interfaces.Unsigned_32;
   begin
      return Search.Handle /= INVALID_HANDLE_VALUE
         and then Search.Is_Valid;
   end More_Entries;

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

   procedure Rename (Old_Name, New_Name : String) is
      use type Interfaces.Unsigned_32;
      --  DBCS Length <= UTF8 Length, "+ 1" for NUL
      Old_Buffer : DBCS_String (1 .. Old_Name'Length + 1);
      Old_Last : Positive;
      New_Buffer : DBCS_String (1 .. New_Name'Length + 1);
      New_Last : Positive;
   begin
      UTF8_To_DBCS (Old_Name, Old_Buffer, Old_Last);
      Old_Buffer (Old_Last + 1) := Character'Val (0);
      UTF8_To_DBCS (New_Name, New_Buffer, New_Last);
      New_Buffer (New_Last + 1) := Character'Val (0);
      if MoveFileExA (Old_Buffer (Old_Buffer'First)'Unrestricted_Access,
         New_Buffer (New_Buffer'First)'Unrestricted_Access, 0) = 0
      then
         case GetLastError is
            when ERROR_FILE_NOT_FOUND | ERROR_PATH_NOT_FOUND =>
               raise Name_Error;
            when others =>
               raise Use_Error;
         end case;
      end if;
   end Rename;

   -------------------
   -- Set_Directory --
   -------------------

   procedure Set_Directory (Directory : String) is
      use type Interfaces.Unsigned_32;
      --  DBCS Length <= UTF8 Length, "+ 1" for NUL
      Buffer : DBCS_String (1 .. Directory'Length + 1);
      Last : Positive;
   begin
      UTF8_To_DBCS (Directory, Buffer, Last);
      Buffer (Last + 1) := Character'Val (0);
      if SetCurrentDirectoryA
         (Buffer (Buffer'First)'Unrestricted_Access) = 0
      then
         case GetLastError is
            when ERROR_FILE_NOT_FOUND | ERROR_PATH_NOT_FOUND =>
               raise Name_Error;
            when others =>
               raise Use_Error;
         end case;
      end if;
   end Set_Directory;

   -----------------
   -- Simple_Name --
   -----------------

   function Simple_Name (Name : String) return String is
   begin
      --  First, the invalid case
      if not Is_Valid_Path_Name (Name) then
         raise Name_Error;
      else
         --  Name as UTF-8
         for I in reverse Name'Range loop
            case Name (I) is
               when ':' | '\' | '/' =>
                  return Name (I + 1 .. Name'Last);
               when others =>
                  null;
            end case;
         end loop;
         return Name;
      end if;
   end Simple_Name;

   function Simple_Name
     (Directory_Entry : Directory_Entry_Type) return String is
   begin
      --  First, the invalid case
      if not Directory_Entry.Is_Valid then
         raise Status_Error;
      else
         --  The value to return has already be computed
         return Directory_Entry.Simple_Name
            (1 .. Directory_Entry.Simple_Length);
      end if;
   end Simple_Name;

   ----------
   -- Size --
   ----------

   function Size (Name : String) return File_Size is
      use type Interfaces.Unsigned_32;
      Data : aliased WIN32_FILE_ATTRIBUTE_DATA;
      --  DBCS Length <= UTF8 Length, "+ 1" for NUL
      Buffer : DBCS_String (1 .. Name'Length + 1);
      Last : Positive;
   begin
      UTF8_To_DBCS (Name, Buffer, Last);
      Buffer (Last + 1) := Character'Val (0);
      if GetFileAttributesExA (
         Buffer (Buffer'First)'Unrestricted_Access,
         GetFileExInfoStandard,
         Data'Access) = 0
      then
         raise Name_Error;
      else
         if To_File_Kind (Data.FileAttributes) /= Ordinary_File then
            raise Name_Error;
         end if;
         return File_Size (To_Unsigned_64
            ((Low => Data.FileSizeLow, High => Data.FileSizeHigh)));
      end if;
   end Size;

   function Size (Directory_Entry : Directory_Entry_Type) return File_Size is
   begin
      --  First, the invalid case
      if not Directory_Entry.Is_Valid
         or else Directory_Entry.Kind /= Ordinary_File
      then
         raise Status_Error;
      else
         --  The value to return has already be computed
         return Directory_Entry.Size;
      end if;
   end Size;

   ------------------
   -- Start_Search --
   ------------------

   procedure Start_Search
     (Search    : in out Search_Type;
      Directory : String;
      Pattern   : String;
      Filter    : Filter_Type := (others => True))
   is
      use type Interfaces.Unsigned_32;
   begin
      --  If needed, finalize Search
      Finalize (Search);
      --  Find first
      declare
         Wildcard : String (1 .. Directory'Length + Pattern'Length + 1);
         Wildcard_Last : Natural;
         --  DBCS Length <= UTF8 Length, "+ 1" for NUL
         Buffer : DBCS_String (1 .. Wildcard'Length + 1);
         Last : Positive;
      begin
         --  Compose wildcard
         Wildcard (1 .. Directory'Length) := Directory;
         case Directory (Directory'Last) is
            when '\' | '/' | ':' =>
               Wildcard (Directory'Length + 1 .. Wildcard'Last - 1) := Pattern;
               Wildcard_Last := Wildcard'Last - 1;
            when others =>
               Wildcard (Directory'Length + 1) := '\';
               Wildcard (Directory'Length + 2 .. Wildcard'Last) := Pattern;
               Wildcard_Last := Wildcard'Last;
         end case;
         --  Convert character code
         UTF8_To_DBCS (Wildcard (1 .. Wildcard_Last), Buffer, Last);
         Buffer (Last + 1) := Character'Val (0);
         --  Start search
         Search.Handle := FindFirstFileA (
            Buffer (Buffer'First)'Unrestricted_Access,
            Search.Data'Access);
      end;
      --  Handling result
      if Search.Handle = INVALID_HANDLE_VALUE then
         case GetLastError is
            when ERROR_FILE_NOT_FOUND | ERROR_NO_MORE_FILES =>
               --  Simply, no files match the pattern.
               Search.Is_Valid := False;
            when others =>
               --  Error by other reason, like invalid path.
               raise Name_Error;
         end case;
      else
         Search.Path := new String'(Directory);
         Search.Filter := Filter;
         Search.Is_Valid := True;
         while not Filter (To_File_Kind (Search.Data.FileAttributes)) loop
            if FindNextFileA (Search.Handle, Search.Data'Access) = 0 then
               Search.Is_Valid := False;
               exit;
            end if;
         end loop;
      end if;
   end Start_Search;

   ------------------
   -- To_File_Kind --
   ------------------

   function To_File_Kind (Attribute : Interfaces.Unsigned_32)
      return File_Kind
   is
      use type Interfaces.Unsigned_32;
   begin
      if (FILE_ATTRIBUTE_DIRECTORY and Attribute) /= 0 then
         return Directory;
      elsif (FILE_ATTRIBUTE_DEVICE and Attribute) /= 0 then
         return Special_File;
      else
         return Ordinary_File;
      end if;
   end To_File_Kind;

   -------------
   -- To_Time --
   -------------

   function To_Time (Time : FILETIME) return Ada.Calendar.Time is
      Detail : aliased SYSTEMTIME;
   begin
      FileTimeToSystemTime (Time'Unrestricted_Access, Detail'Access);
      return Ada.Calendar.Time_Of (
         Ada.Calendar.Year_Number (Detail.Year),
         Ada.Calendar.Month_Number (Detail.Month),
         Ada.Calendar.Day_Number (Detail.Day),
         (Duration (Detail.Hour) * 60 + Duration (Detail.Minute)) * 60 +
         Duration (Detail.Second));
   end To_Time;

   ------------------
   -- UTF8_To_DBCS --
   ------------------

   procedure UTF8_To_DBCS (Source : in String;
      Dest : out DBCS_String; Last : out Natural)
   is
      procedure UTF8_To_UTF16 (Source : in String;
         Dest : out Wide_String; Last : out Natural);
      procedure UTF8_To_UTF16 (Source : in String;
         Dest : out Wide_String; Last : out Natural)
      is
         pragma Suppress (Index_Check);
      begin
         Last := Dest'First - 1 + Natural (MultiByteToWideChar (CP_UTF8, 0,
            Source (Source'First)'Unrestricted_Access, Source'Length,
            Dest (Dest'First)'Unrestricted_Access, Dest'Length));
      end UTF8_To_UTF16;
      pragma Suppress (Index_Check);
      Temp : Wide_String (1 .. Source'Length + 1);
      Temp_Last : Natural;
   begin
      UTF8_To_UTF16 (Source, Temp, Temp_Last);
      Last := Dest'First - 1 + Natural (WideCharToMultiByte (CP_ACP, 0,
         Temp (Temp'First)'Unrestricted_Access,
         Interfaces.Integer_32 (Temp_Last),
         Dest (Dest'First)'Unrestricted_Access, Dest'Length,
         DefaultChar => null, UsedDefaultChar => null));
   end UTF8_To_DBCS;

end Ada.Directories;

Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]