+% -----------------------------------------------------------------------------
%
-% (c) The AQUA Project, Glasgow University, 1994-1997
+% (c) The University of Glasgow, 1994-
%
-\section[Directory]{Directory interface}
+% The Directory Interface
A directory contains a series of entries, each of which is a named
reference to a file system object (file, directory etc.). Some
are relative to the current directory.
\begin{code}
-{-# OPTIONS -#include <sys/stat.h> #-}
+{-# OPTIONS -#include "dirUtils.h" -#include "PrelIOUtils.h" #-}
module Directory
(
- Permissions(Permissions),
-
- createDirectory,
- removeDirectory,
- renameDirectory,
- getDirectoryContents,
- getCurrentDirectory,
- setCurrentDirectory,
-
- removeFile,
- renameFile,
-
- doesFileExist,
- doesDirectoryExist,
- getPermissions,
- setPermissions,
- getModificationTime
- ) where
+ Permissions -- instance of (Eq, Ord, Read, Show)
+ ( Permissions
+ , readable -- :: Permissions -> Bool
+ , writable -- :: Permissions -> Bool
+ , executable -- :: Permissions -> Bool
+ , searchable -- :: Permissions -> Bool
+ )
-import PrelBase
-import PrelIOBase
-import PrelST
-import PrelUnsafe ( unsafePerformIO )
-import PrelArr
-import PrelPack ( unpackNBytesST )
-import PrelForeign ( Word(..) )
-import PrelAddr
-import Time ( ClockTime(..) )
+ , createDirectory -- :: FilePath -> IO ()
+ , removeDirectory -- :: FilePath -> IO ()
+ , renameDirectory -- :: FilePath -> FilePath -> IO ()
-\end{code}
+ , getDirectoryContents -- :: FilePath -> IO [FilePath]
+ , getCurrentDirectory -- :: IO FilePath
+ , setCurrentDirectory -- :: FilePath -> IO ()
-%*********************************************************
-%* *
-\subsection{Signatures}
-%* *
-%*********************************************************
+ , removeFile -- :: FilePath -> IO ()
+ , renameFile -- :: FilePath -> FilePath -> IO ()
-\begin{code}
-createDirectory :: FilePath -> IO ()
-removeDirectory :: FilePath -> IO ()
-removeFile :: FilePath -> IO ()
-renameDirectory :: FilePath -> FilePath -> IO ()
-renameFile :: FilePath -> FilePath -> IO ()
-getDirectoryContents :: FilePath -> IO [FilePath]
-getCurrentDirectory :: IO FilePath
-setCurrentDirectory :: FilePath -> IO ()
-doesFileExist :: FilePath -> IO Bool
-doesDirectoryExist :: FilePath -> IO Bool
-getPermissions :: FilePath -> IO Permissions
-setPermissions :: FilePath -> Permissions -> IO ()
-getModificationTime :: FilePath -> IO ClockTime
-\end{code}
+ , doesFileExist -- :: FilePath -> IO Bool
+ , doesDirectoryExist -- :: FilePath -> IO Bool
+ , getPermissions -- :: FilePath -> IO Permissions
+ , setPermissions -- :: FilePath -> Permissions -> IO ()
-%*********************************************************
-%* *
-\subsection{Permissions}
-%* *
-%*********************************************************
+ , getModificationTime -- :: FilePath -> IO ClockTime
+ ) where
+
+import Prelude -- Just to get it in the dependencies
+
+import Time ( ClockTime(..) )
+
+import PrelPosix
+import PrelStorable
+import PrelCString
+import PrelMarshalAlloc
+import PrelCTypesISO
+import PrelCTypes
+import PrelCError
+import PrelPtr
+import PrelIOBase
+import PrelBase
+\end{code}
+
+-----------------------------------------------------------------------------
+-- Permissions
The @Permissions@ type is used to record whether certain
operations are permissible on a file/directory:
-[to whom? - owner/group/world - the Report don't say much]
+[to whom? - presumably the "current user"]
\begin{code}
data Permissions
= Permissions {
- readable, writeable,
+ readable, writable,
executable, searchable :: Bool
} deriving (Eq, Ord, Read, Show)
\end{code}
-%*********************************************************
-%* *
-\subsection{Implementation}
-%* *
-%*********************************************************
+-----------------------------------------------------------------------------
+-- Implementation
@createDirectory dir@ creates a new directory {\em dir} which is
initially empty, or as near to empty as the operating system
\end{itemize}
\begin{code}
+createDirectory :: FilePath -> IO ()
createDirectory path = do
- rc <- _ccall_ createDirectory path
- if rc == 0 then return () else
- constructErrorAndFail "createDirectory"
+ withCString path $ \s -> do
+ throwErrnoIfMinus1Retry_ "createDirectory" $
+ mkdir s 0o777
\end{code}
@removeDirectory dir@ removes an existing directory {\em dir}. The
\end{itemize}
\begin{code}
+removeDirectory :: FilePath -> IO ()
removeDirectory path = do
- rc <- _ccall_ removeDirectory path
- if rc == 0 then
- return ()
- else
- constructErrorAndFail "removeDirectory"
+ withCString path $ \s ->
+ throwErrnoIfMinus1Retry_ "removeDirectory" (rmdir s)
+
\end{code}
-@removeFile file@ removes the directory entry for an existing file
+@Removefile file@ removes the directory entry for an existing file
{\em file}, where {\em file} is not itself a directory. The
implementation may specify additional constraints which must be
satisfied before a file can be removed (e.g. the file may not be in
\end{itemize}
\begin{code}
+removeFile :: FilePath -> IO ()
removeFile path = do
- rc <- _ccall_ removeFile path
- if rc == 0 then
- return ()
- else
- constructErrorAndFail "removeFile"
+ withCString path $ \s ->
+ throwErrnoIfMinus1Retry_ "removeFile" (unlink s)
+
\end{code}
-@renameDirectory old@ {\em new} changes the name of an existing
+@renameDirectory@ {\em old} {\em new} changes the name of an existing
directory from {\em old} to {\em new}. If the {\em new} directory
already exists, it is atomically replaced by the {\em old} directory.
If the {\em new} directory is neither the {\em old} directory nor an
\end{itemize}
\begin{code}
-renameDirectory opath npath = do
- rc <- _ccall_ renameDirectory opath npath
- if rc == 0 then
- return ()
- else
- constructErrorAndFail "renameDirectory"
+renameDirectory :: FilePath -> FilePath -> IO ()
+renameDirectory opath npath =
+ withFileStatus opath $ \st -> do
+ is_dir <- isDirectory st
+ if (not is_dir)
+ then ioException (IOError Nothing InappropriateType "renameDirectory"
+ ("not a directory") (Just opath))
+ else do
+
+ withCString opath $ \s1 ->
+ withCString npath $ \s2 ->
+ throwErrnoIfMinus1Retry_ "renameDirectory" (rename s1 s2)
+
\end{code}
-@renameFile old@ {\em new} changes the name of an existing file system
+@renameFile@ {\em old} {\em new} changes the name of an existing file system
object from {\em old} to {\em new}. If the {\em new} object already
exists, it is atomically replaced by the {\em old} object. Neither
path may refer to an existing directory. A conformant implementation
\end{itemize}
\begin{code}
-renameFile opath npath = do
- rc <- _ccall_ renameFile opath npath
- if rc == 0 then
- return ()
- else
- constructErrorAndFail "renameFile"
+renameFile :: FilePath -> FilePath -> IO ()
+renameFile opath npath =
+ withFileOrSymlinkStatus opath $ \st -> do
+ is_dir <- isDirectory st
+ if is_dir
+ then ioException (IOError Nothing InappropriateType "renameFile"
+ "is a directory" (Just opath))
+ else do
+
+ withCString opath $ \s1 ->
+ withCString npath $ \s2 ->
+ throwErrnoIfMinus1Retry_ "renameFile" (rename s1 s2)
+
\end{code}
@getDirectoryContents dir@ returns a list of {\em all} entries
\end{itemize}
\begin{code}
+getDirectoryContents :: FilePath -> IO [FilePath]
getDirectoryContents path = do
- ptr <- _ccall_ getDirectoryContents path
- if ptr == ``NULL''
- then constructErrorAndFail "getDirectoryContents"
- else do
- entries <- getEntries ptr 0
- _ccall_ free ptr
- return entries
+ alloca $ \ ptr_dEnt -> do
+ p <- withCString path $ \s ->
+ throwErrnoIfNullRetry "getDirectoryContents" (opendir s)
+ loop ptr_dEnt p
where
- getEntries :: Addr -> Int -> IO [FilePath]
- getEntries ptr n = do
- str <- _casm_ ``%r = ((char **)%0)[%1];'' ptr n
- if str == ``NULL''
- then return []
- else do
- len <- _ccall_ strlen str
- entry <- stToIO (unpackNBytesST str len)
- _ccall_ free str
- entries <- getEntries ptr (n+1)
- return (entry : entries)
+ loop :: Ptr (Ptr CDirent) -> Ptr CDir -> IO [String]
+ loop ptr_dEnt dir = do
+ resetErrno
+ r <- readdir dir ptr_dEnt
+ if (r == 0)
+ then do
+ dEnt <- peek ptr_dEnt
+ entry <- (d_name dEnt >>= peekCString)
+ freeDirEnt dEnt
+ entries <- loop ptr_dEnt dir
+ return (entry:entries)
+ else do errno <- getErrno
+ if (errno == eINTR) then loop ptr_dEnt dir else do
+ throwErrnoIfMinus1_ "getDirectoryContents" $ closedir dir
+ let (Errno eo) = errno
+ if (eo == end_of_dir)
+ then return []
+ else throwErrno "getDirectoryContents"
+
+foreign import ccall "prel_end_of_dir" unsafe end_of_dir :: CInt
+foreign import ccall "prel_d_name" unsafe d_name :: Ptr CDirent -> IO CString
+
\end{code}
If the operating system has a notion of current directories,
\end{itemize}
\begin{code}
+getCurrentDirectory :: IO FilePath
getCurrentDirectory = do
- str <- _ccall_ getCurrentDirectory
- if str /= ``NULL''
- then do
- len <- _ccall_ strlen str
- pwd <- stToIO (unpackNBytesST str len)
- _ccall_ free str
- return pwd
- else
- constructErrorAndFail "getCurrentDirectory"
+ p <- mallocBytes path_max
+ go p path_max
+ where go p bytes = do
+ p' <- getcwd p (fromIntegral bytes)
+ if p' /= nullPtr
+ then do s <- peekCString p'
+ free p'
+ return s
+ else do errno <- getErrno
+ if errno == eRANGE
+ then do let bytes' = bytes * 2
+ p' <- reallocBytes p bytes'
+ go p' bytes'
+ else throwErrno "getCurrentDirectory"
+
+foreign import ccall "prel_path_max" unsafe path_max :: Int
+
\end{code}
If the operating system has a notion of current directories,
\end{itemize}
\begin{code}
+setCurrentDirectory :: FilePath -> IO ()
setCurrentDirectory path = do
- rc <- _ccall_ setCurrentDirectory path
- if rc == 0
- then return ()
- else constructErrorAndFail "setCurrentDirectory"
+ withCString path $ \s ->
+ throwErrnoIfMinus1Retry_ "setCurrentDirectory" (chdir s)
+ -- ToDo: add path to error
+
\end{code}
+To clarify, @doesDirectoryExist@ returns True if a file system object
+exist, and it's a directory. @doesFileExist@ returns True if the file
+system object exist, but it's not a directory (i.e., for every other
+file system object that is not a directory.)
\begin{code}
---doesFileExist :: FilePath -> IO Bool
-doesFileExist name = do
- rc <- _ccall_ access name (``F_OK''::Int)
- return (rc == 0)
-
---doesDirectoryExist :: FilePath -> IO Bool
+doesDirectoryExist :: FilePath -> IO Bool
doesDirectoryExist name =
- (getFileStatus name >>= \ st -> return (isDirectory st))
- `catch`
- (\ _ -> return False)
+ catch
+ (withFileStatus name $ \st -> isDirectory st)
+ (\ _ -> return False)
+
+doesFileExist :: FilePath -> IO Bool
+doesFileExist name = do
+ catch
+ (withFileStatus name $ \st -> do b <- isDirectory st; return (not b))
+ (\ _ -> return False)
---getModificationTime :: FilePath -> IO ClockTime
+getModificationTime :: FilePath -> IO ClockTime
getModificationTime name =
- getFileStatus name >>= \ st ->
+ withFileStatus name $ \ st ->
modificationTime st
---getPermissions :: FilePath -> IO Permissions
-getPermissions name =
- getFileStatus name >>= \ st ->
- let
- fm = fileMode st
- isect v = intersectFileMode v fm == v
- in
+getPermissions :: FilePath -> IO Permissions
+getPermissions name = do
+ withCString name $ \s -> do
+ read <- access s r_OK
+ write <- access s w_OK
+ exec <- access s x_OK
+ withFileStatus name $ \st -> do
+ is_dir <- isDirectory st
+ is_reg <- isRegularFile st
return (
Permissions {
- readable = isect ownerReadMode,
- writeable = isect ownerWriteMode,
- executable = not (isDirectory st) && isect ownerExecuteMode,
- searchable = not (isRegularFile st) && isect ownerExecuteMode
+ readable = read == 0,
+ writable = write == 0,
+ executable = not is_dir && exec == 0,
+ searchable = not is_reg && exec == 0
}
- )
+ )
+
+foreign import ccall "prel_R_OK" unsafe r_OK :: CMode
+foreign import ccall "prel_W_OK" unsafe w_OK :: CMode
+foreign import ccall "prel_X_OK" unsafe x_OK :: CMode
---setPermissions :: FilePath -> Permissions -> IO ()
+setPermissions :: FilePath -> Permissions -> IO ()
setPermissions name (Permissions r w e s) = do
let
- read# = case (if r then ownerReadMode else ``0'') of { W# x# -> x# }
- write# = case (if w then ownerWriteMode else ``0'') of { W# x# -> x# }
- exec# = case (if e || s then ownerExecuteMode else ``0'') of { W# x# -> x# }
-
- mode = I# (word2Int# (read# `or#` write# `or#` exec#))
+ read = if r then s_IRUSR else emptyCMode
+ write = if w then s_IWUSR else emptyCMode
+ exec = if e || s then s_IXUSR else emptyCMode
+
+ mode = read `unionCMode` (write `unionCMode` exec)
+
+ withCString name $ \s ->
+ throwErrnoIfMinus1_ "setPermissions" $ chmod s mode
+
+foreign import ccall "prel_S_IRUSR" unsafe s_IRUSR :: CMode
+foreign import ccall "prel_S_IWUSR" unsafe s_IWUSR :: CMode
+foreign import ccall "prel_S_IXUSR" unsafe s_IXUSR :: CMode
+
+withFileStatus :: FilePath -> (Ptr CStat -> IO a) -> IO a
+withFileStatus name f = do
+ allocaBytes sizeof_stat $ \p ->
+ withCString name $ \s -> do
+ throwErrnoIfMinus1Retry_ "withFileStatus" (stat s p)
+ f p
+
+withFileOrSymlinkStatus :: FilePath -> (Ptr CStat -> IO a) -> IO a
+withFileOrSymlinkStatus name f = do
+ allocaBytes sizeof_stat $ \p ->
+ withCString name $ \s -> do
+ throwErrnoIfMinus1Retry_ "withFileOrSymlinkStatus" (lstat s p)
+ f p
+
+modificationTime :: Ptr CStat -> IO ClockTime
+modificationTime stat = do
+ mtime <- st_mtime stat
+ return (TOD (toInteger (mtime :: CTime)) 0)
+
+isDirectory :: Ptr CStat -> IO Bool
+isDirectory stat = do
+ mode <- st_mode stat
+ return (s_ISDIR mode /= 0)
- rc <- _ccall_ chmod name mode
- if rc == 0
- then return ()
- else fail (IOError Nothing SystemError "Directory.setPermissions")
+isRegularFile :: Ptr CStat -> IO Bool
+isRegularFile stat = do
+ mode <- st_mode stat
+ return (s_ISREG mode /= 0)
-\end{code}
+foreign import ccall "prel_s_ISDIR" unsafe s_ISDIR :: CMode -> Int
+foreign import ccall "prel_s_ISREG" unsafe s_ISREG :: CMode -> Int
+emptyCMode :: CMode
+emptyCMode = 0
-(Sigh)..copied from Posix.Files to avoid dep. on posix library
+unionCMode :: CMode -> CMode -> CMode
+unionCMode = (+)
-\begin{code}
-type FileStatus = ByteArray Int
+foreign import ccall "prel_mkdir" unsafe mkdir :: CString -> CInt -> IO CInt
-getFileStatus :: FilePath -> IO FileStatus
-getFileStatus name = do
- bytes <- stToIO (newCharArray (0,``sizeof(struct stat)''))
- rc <- _casm_ ``%r = stat(%0,(struct stat *)%1);'' name bytes
- if rc == 0
- then stToIO (unsafeFreezeByteArray bytes)
- else fail (IOError Nothing SystemError "Directory.getFileStatus")
-
-modificationTime :: FileStatus -> IO ClockTime
-modificationTime stat = do
- i1 <- malloc1
- _casm_ ``((unsigned long *)%1)[0] = ((struct stat *)%0)->st_mtime;'' stat i1
- secs <- cvtUnsigned i1
- return (TOD secs 0)
- where
- malloc1 = IO $ \ s# ->
- case newIntArray# 1# s# of
- StateAndMutableByteArray# s2# barr# ->
- IOok s2# (MutableByteArray bnds barr#)
-
- bnds = (0,1)
- -- The C routine fills in an unsigned word. We don't have `unsigned2Integer#,'
- -- so we freeze the data bits and use them for an MP_INT structure. Note that
- -- zero is still handled specially, although (J# 1# 1# (ptr to 0#)) is probably
- -- acceptable to gmp.
-
- cvtUnsigned (MutableByteArray _ arr#) = IO $ \ s# ->
- case readIntArray# arr# 0# s# of
- StateAndInt# s2# r# ->
- if r# ==# 0# then
- IOok s2# 0
- else
- case unsafeFreezeByteArray# arr# s2# of
- StateAndByteArray# s3# frozen# ->
- IOok s3# (J# 1# 1# frozen#)
-
-isDirectory :: FileStatus -> Bool
-isDirectory stat = unsafePerformIO $ do
- rc <- _casm_ ``%r = S_ISDIR(((struct stat *)%0)->st_mode);'' stat
- return (rc /= 0)
-
-isRegularFile :: FileStatus -> Bool
-isRegularFile stat = unsafePerformIO $ do
- rc <- _casm_ ``%r = S_ISREG(((struct stat *)%0)->st_mode);'' stat
- return (rc /= 0)
-\end{code}
-
-\begin{code}
-type FileMode = Word
-ownerReadMode :: FileMode
-ownerReadMode = ``S_IRUSR''
+foreign import ccall unsafe chmod :: CString -> CMode -> IO CInt
+foreign import ccall unsafe access :: CString -> CMode -> IO CInt
+foreign import ccall unsafe rmdir :: CString -> IO CInt
+foreign import ccall unsafe chdir :: CString -> IO CInt
+foreign import ccall unsafe getcwd :: Ptr CChar -> CInt -> IO (Ptr CChar)
+foreign import ccall unsafe unlink :: CString -> IO CInt
+foreign import ccall unsafe rename :: CString -> CString -> IO CInt
+
+foreign import ccall unsafe opendir :: CString -> IO (Ptr CDir)
+foreign import ccall unsafe closedir :: Ptr CDir -> IO CInt
-ownerWriteMode :: FileMode
-ownerWriteMode = ``S_IWUSR''
+foreign import ccall unsafe stat :: CString -> Ptr CStat -> IO CInt
-ownerExecuteMode :: FileMode
-ownerExecuteMode = ``S_IXUSR''
+foreign import ccall "prel_lstat" unsafe lstat :: CString -> Ptr CStat -> IO CInt
+foreign import ccall "prel_readdir" unsafe readdir :: Ptr CDir -> Ptr (Ptr CDirent) -> IO CInt
+foreign import ccall "prel_free_dirent" unsafe freeDirEnt :: Ptr CDirent -> IO ()
-intersectFileMode :: FileMode -> FileMode -> FileMode
-intersectFileMode (W# m1#) (W# m2#) = W# (m1# `and#` m2#)
-fileMode :: FileStatus -> FileMode
-fileMode stat = unsafePerformIO (
- _casm_ ``%r = ((struct stat *)%0)->st_mode;'' stat)
+type CDirent = ()
\end{code}
projects / ghc-hetmet.git / blobdiff