File : posix-files.adb


------------------------------------------------------------------------------
--                                                                          --
--            FLORIST (FSU Implementation of POSIX.5) COMPONENTS            --
--                                                                          --
--                           P O S I X . F I L E S                          --
--                                                                          --
--                                  B o d y                                 --
--                                                                          --
--                                                                          --
--  Copyright (c)  1996-1998            Florida  State  University  (FSU),  --
--  All Rights Reserved.                                                    --
--                                                                          --
--  This file is a component of FLORIST, an  implementation of an  Ada API  --
--  for the POSIX OS services, for use with  the  GNAT  Ada  compiler  and  --
--  the FSU Gnu Ada Runtime Library (GNARL).   The  interface  is intended  --
--  to be close to that specified in  IEEE STD  1003.5: 1990  and IEEE STD  --
--  1003.5b: 1996.                                                          --
--                                                                          --
--  FLORIST is free software;  you can  redistribute  it and/or  modify it  --
--  under terms of the  GNU  General  Public  License as  published by the  --
--  Free Software Foundation;  either version  2, or (at  your option) any  --
--  later version.  FLORIST is distributed  in  the hope  that  it will be  --
--  useful, but WITHOUT 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  GNARL;  see  --
--  file  COPYING.  If not,  write to  the  Free  Software  Foundation, 59  --
--  Temple Place - Suite 330, Boston, MA 02111-1307, 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.                                      --
--                                                                          --
------------------------------------------------------------------------------
--  [$Revision: 1.1.1.1 $]

with POSIX.C,
     POSIX.Calendar,
     POSIX.Implementation,
     POSIX.File_Status,
     POSIX.Permissions,
     POSIX.Permissions.Implementation,
     System,
     Unchecked_Conversion;
package body POSIX.Files is

   use POSIX,
       POSIX.C,
       POSIX.Implementation,
       POSIX.Permissions.Implementation;

   -------------------------
   --  Local Subprograms  --
   -------------------------

   function To_D_Int is
     new Unchecked_Conversion (POSIX.Calendar.POSIX_Time, D_Int);

   function To_time_t (Time : POSIX.Calendar.POSIX_Time) return time_t;

   function To_time_t (Time : POSIX.Calendar.POSIX_Time) return time_t is
   begin
      return time_t (To_Duration (To_D_Int (Time) / NS_per_S) * NS_per_S);
   end To_time_t;

   function c_access
     (path  : char_ptr;
      amode : int) return int;
   pragma Import (C, c_access, access_LINKNAME);

   function Form_C_access
     (Modes : POSIX.Files.Access_Mode_Set) return int;

   function Form_C_access
     (Modes : POSIX.Files.Access_Mode_Set) return int is
      c_access : Bits := 0;
   begin
      if Modes (Read_Ok) then
         c_access := c_access or R_OK;
      end if;
      if Modes (Write_Ok) then
         c_access := c_access or W_OK;
      end if;
      if Modes (Execute_Ok) then
         c_access := c_access or X_OK;
      end if;
      return int (c_access);
   end Form_C_access;

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

   function mkdir
     (path : char_ptr;
      mode : mode_t) return int;
   pragma Import (C, mkdir, mkdir_LINKNAME);

   procedure Create_Directory
     (Pathname   : in POSIX.Pathname;
      Permission : in POSIX.Permissions.Permission_Set) is
      Pathname_With_NUL : POSIX_String := Pathname & NUL;
   begin
      Check (mkdir (Pathname_With_NUL
        (Pathname_With_NUL'First)'Unchecked_Access,
        (Form_C_Permission (Permission))));
   end Create_Directory;

   -------------------
   --  Create_FIFO  --
   -------------------

   function mkfifo
     (path : char_ptr;
      mode : mode_t) return int;
   pragma Import (C, mkfifo, mkfifo_LINKNAME);

   procedure Create_FIFO
     (Pathname   : in POSIX.Pathname;
      Permission : in POSIX.Permissions.Permission_Set) is
      Pathname_With_NUL : POSIX_String := Pathname & NUL;
   begin
      Check (mkfifo (Pathname_With_NUL
        (Pathname_With_NUL'First)'Unchecked_Access,
        (Form_C_Permission (Permission))));
   end Create_FIFO;

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

   function unlink (path : char_ptr) return int;
   pragma Import (C, unlink, unlink_LINKNAME);

   procedure Unlink (Pathname : in POSIX.Pathname) is
      Pathname_With_NUL : POSIX_String := Pathname & NUL;
   begin
      Check (unlink (Pathname_With_NUL
       (Pathname_With_NUL'First)'Unchecked_Access));
   end Unlink;

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

   function rmdir (path : char_ptr) return int;
   pragma Import (C, rmdir, rmdir_LINKNAME);

   procedure Remove_Directory (Pathname : in POSIX.Pathname) is
      Pathname_With_NUL : POSIX_String := Pathname & NUL;
   begin
      Check (rmdir (Pathname_With_NUL
       (Pathname_With_NUL'First)'Unchecked_Access));
   end Remove_Directory;

   ------------------------
   --  Is_Symbolic_Link  --
   ------------------------

   function Is_Symbolic_Link (Pathname : POSIX.Pathname) return Boolean is
      stat : POSIX.File_Status.Status;
   begin
      stat := POSIX.File_Status.Get_File_Status (Pathname);
      return (POSIX.File_Status.Is_Symbolic_Link (stat));
   exception
      when POSIX_Error => return False;
   end Is_Symbolic_Link;

   ---------------
   --  Is_File  --
   ---------------

   function Is_File (Pathname : POSIX.Pathname) return Boolean is
      stat : POSIX.File_Status.Status;
   begin
      stat := POSIX.File_Status.Get_File_Status (Pathname);
      return (POSIX.File_Status.Is_Regular_File (stat));
   exception
      when POSIX_Error => return False;
   end Is_File;

   -----------------
   --  Is_Socket  --
   -----------------

   function Is_Socket (Pathname : POSIX.Pathname) return Boolean is
      stat : POSIX.File_Status.Status;
   begin
      stat := POSIX.File_Status.Get_File_Status (Pathname);
      return (POSIX.File_Status.Is_Socket (stat));
   exception
      when POSIX_Error => return False;
   end Is_Socket;

   --------------------
   --  Is_Directory  --
   --------------------

   function Is_Directory (Pathname : POSIX.Pathname) return Boolean is
      stat : POSIX.File_Status.Status;
   begin
      stat := POSIX.File_Status.Get_File_Status (Pathname);
      return (POSIX.File_Status.Is_Directory (stat));
   exception
      when POSIX_Error => return False;
   end Is_Directory;

   ---------------
   --  Is_FIFO  --
   ---------------

   function Is_FIFO (Pathname : POSIX.Pathname) return Boolean is
      stat : POSIX.File_Status.Status;
   begin
      stat := POSIX.File_Status.Get_File_Status (Pathname);
      return (POSIX.File_Status.Is_FIFO (stat));
   exception
      when POSIX_Error => return False;
   end Is_FIFO;

   ---------------------------------
   --  Is_Character_Special_File  --
   ---------------------------------

   function Is_Character_Special_File
     (Pathname : POSIX.Pathname) return Boolean is
      stat : POSIX.File_Status.Status;
   begin
      stat := POSIX.File_Status.Get_File_Status (Pathname);
      return (POSIX.File_Status.Is_Character_Special_File (stat));
   exception
      when POSIX_Error => return False;
   end Is_Character_Special_File;

   -----------------------------
   --  Is_Block_Special_File  --
   -----------------------------

   function Is_Block_Special_File
     (Pathname : POSIX.Pathname) return Boolean is
      stat : POSIX.File_Status.Status;
   begin
      stat := POSIX.File_Status.Get_File_Status (Pathname);
      return (POSIX.File_Status.Is_Block_Special_File (stat));
   exception
      when POSIX_Error => return False;
   end Is_Block_Special_File;

   ------------
   --  Link  --
   ------------

   function link
     (existing : char_ptr;
      new_name : char_ptr) return int;
   pragma Import (C, link, link_LINKNAME);

   procedure Link
     (Old_Pathname : in Pathname;
      New_Pathname : in Pathname) is
      Old_Pathname_With_NUL : POSIX_String := Old_Pathname & NUL;
      New_Pathname_With_NUL : POSIX_String := New_Pathname & NUL;
   begin
      Check (link (Old_Pathname_With_NUL
         (Old_Pathname_With_NUL'First)'Unchecked_Access,
        New_Pathname_With_NUL (New_Pathname_With_NUL'First)'Unchecked_Access));
   end Link;

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

   function rename
     (old_name : char_ptr;
      new_name : char_ptr) return int;
   pragma Import (C, rename, rename_LINKNAME);

   procedure Rename
     (Old_Pathname : in Pathname;
      New_Pathname : in Pathname) is
      Old_Pathname_With_NUL : POSIX_String := Old_Pathname & NUL;
      New_Pathname_With_NUL : POSIX_String := New_Pathname & NUL;
   begin
      Check (rename (Old_Pathname_With_NUL
         (Old_Pathname_With_NUL'First)'Unchecked_Access,
        New_Pathname_With_NUL (New_Pathname_With_NUL'First)'Unchecked_Access));
   end Rename;

   -------------------
   --  Filename_Of  --
   -------------------

   function To_char_ptr is
     new Unchecked_Conversion (System.Address, char_ptr);

   function Filename_Of (D_Entry : Directory_Entry)
      return Filename is
   begin
      return Form_POSIX_String
        (To_char_ptr (D_Entry.d_name (1)'Address));
   end Filename_Of;

   ---------------------------------
   --  For_Every_Directory_Entry  --
   ---------------------------------

   function opendir (dirname : char_ptr) return DIR_ptr;
   pragma Import (C, opendir, opendir_LINKNAME);

   function readdir (dirp : DIR_ptr) return dirent_ptr;
   pragma Import (C, readdir, readdir_LINKNAME);

   function closedir (dirp : DIR_ptr) return int;
   pragma Import (C, closedir, closedir_LINKNAME);

   --  ?????
   --  The following needs to be made safe for use in a multitasking
   --  environment.

   --  Clearly, readdir is a problem, since it returns a pointer to a
   --  structure that must be allocated somewhere.  Thus, POSIX provides
   --  readdir_r.  We should probably add conditional compilation code to
   --  Florist posix-files.adb to make use of readdir_r if that is
   --  supported.

   --  Note that we are not required to support safe concurrent use of
   --  multiple iterators on the same directory.  A non-normative note
   --  has been placed in 3.3.5 on lines 19-22 to make this clear.  It
   --  says:

   --   The requirement for tasking safety does not imply any greater
   --   degree of safety for concurrent use than is requird of the
   --   standard Ada libraries by the Ada RM.  That is, unless it is so
   --   specified elsewhere in this standard, operations are [missin "not"
   --   here, which is a typo] necessarily atomic and are not necessarily
   --   safe to execute concurrently on the same data object.

   --  Thus, the thing is to cover the case where readdir is the only
   --  thing available, and it is not safe for concurrent use (even on
   --  different directories).

   procedure For_Every_Directory_Entry (Pathname : in POSIX.Pathname) is
      Pathname_With_NUL : POSIX_String := Pathname & NUL;
      dirp : DIR_ptr;
      dirent : dirent_ptr;
      Quit : Boolean := False;
   begin
      dirp := opendir (Pathname_With_NUL
        (Pathname_With_NUL'First)'Unchecked_Access);
      if dirp = null then Raise_POSIX_Error;
      end if;
      loop
         dirent := readdir (dirp);
         exit when dirent = null;
         Action (Directory_Entry (dirent), Quit);
         exit when Quit;
      end loop;
      Check (closedir (dirp));
   end For_Every_Directory_Entry;

   ------------------------------
   --  Change_Owner_And_Group  --
   ------------------------------

   function chown
     (path  : char_ptr;
      owner : uid_t;
      group : gid_t) return int;
   pragma Import (C, chown, chown_LINKNAME);

   function To_uid_t is new Unchecked_Conversion
     (POSIX.Process_Identification.User_ID, uid_t);
   function To_gid_t is new Unchecked_Conversion
     (POSIX.Process_Identification.Group_ID, gid_t);

   procedure Change_Owner_And_Group
     (Pathname : in POSIX.Pathname;
      Owner    : in POSIX.Process_Identification.User_ID;
      Group    : in POSIX.Process_Identification.Group_ID) is
      Pathname_With_NUL : POSIX_String := Pathname & NUL;
   begin
      Check (chown (Pathname_With_NUL
          (Pathname_With_NUL'First)'Unchecked_Access,
         To_uid_t (Owner), To_gid_t (Group)));
   end Change_Owner_And_Group;

   --------------------------
   --  Change_Permissions  --
   --------------------------

   function chmod
     (path : char_ptr;
      mode : mode_t) return int;
   pragma Import (C, chmod, chmod_LINKNAME);

   procedure Change_Permissions
     (Pathname   : in POSIX.Pathname;
      Permission : in POSIX.Permissions.Permission_Set) is
      Pathname_With_NUL : POSIX_String := Pathname & NUL;
   begin
      Check (chmod (Pathname_With_NUL
          (Pathname_With_NUL'First)'Unchecked_Access,
         Form_C_Permission (Permission)));
   end Change_Permissions;

   ----------------------
   --  Set_File_Times  --
   ----------------------

   --  There is a problem in the difference between POSIX.1c and POSIX.5
   --  definition of file related times. POSIX.1c requires the accuracy be
   --  in seconds while POSIX.5 requires it to be in POSIX_Time.
   --  To avoid inconsistency, we have implemented POSIX_Time so that
   --  all time values are truncated to the nearest second.

   function utime
     (path   : char_ptr;
      actime : utimbuf_ptr) return int;
   pragma Import (C, utime, utime_LINKNAME);

   procedure Set_File_Times
     (Pathname          : in POSIX.Pathname;
      Access_Time       : in POSIX.Calendar.POSIX_Time;
      Modification_Time : in POSIX.Calendar.POSIX_Time) is
      Pathname_With_NUL : POSIX_String := Pathname & NUL;
      Times : aliased struct_utimbuf;
   begin
      Times.actime := To_time_t (Access_Time);
      Times.modtime := To_time_t (Modification_Time);
      Check (utime (Pathname_With_NUL
          (Pathname_With_NUL'First)'Unchecked_Access,
         Times'Unchecked_Access));
   end Set_File_Times;

   ----------------------
   --  Set_File_Times  --
   ----------------------

   procedure Set_File_Times (Pathname : in POSIX.Pathname) is
      Pathname_With_NUL : POSIX_String := Pathname & NUL;
   begin
      Check (utime (Pathname_With_NUL
        (Pathname_With_NUL'First)'Unchecked_Access, null));
   end Set_File_Times;

   ---------------------
   --  Is_Accessible  --
   ---------------------

   function Is_Accessible
     (Pathname : POSIX.Pathname;
      Access_Modes : Access_Mode_Set) return Boolean is
   begin
      return Accessibility (Pathname, Access_Modes) = No_Error;
   end Is_Accessible;

   -----------------------
   --  Accessibilitity  --
   -----------------------

   function Accessibility
     (Pathname : POSIX.Pathname;
      Access_Modes : Access_Mode_Set) return Error_Code is
      Pathname_With_NUL : POSIX_String := Pathname & NUL;
   begin
      if c_access
        (Pathname_With_NUL (Pathname_With_NUL'First)'Unchecked_Access,
         Form_C_access (Access_Modes)) = 0
      then return No_Error;
      else return Fetch_Errno;
      end if;
   end Accessibility;

   -----------------------
   --  Is_File_Present  --
   -----------------------

   function Is_File_Present
     (Pathname : POSIX.Pathname) return Boolean is
      Pathname_With_NUL : POSIX_String := Pathname & NUL;
   begin
      return c_access (Pathname_With_NUL
        (Pathname_With_NUL'First)'Unchecked_Access, 0) = 0;
   end Is_File_Present;

   -----------------
   --  Existence  --
   -----------------

   function Existence
     (Pathname : POSIX.Pathname) return Error_Code is
   begin
      if Is_File_Present (Pathname) then return No_Error;
      else return Fetch_Errno;
      end if;
   end Existence;

end POSIX.Files;