+% -----------------------------------------------------------------------------
%
-% (c) The AQUA Project, Glasgow University, 1994-1999
+% (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> -#include <dirent.h> -#include "cbits/stgio.h" #-}
+{-# OPTIONS -#include "dirUtils.h" -#include "PrelIOUtils.h" #-}
module Directory
(
- Permissions -- abstract
-
- , readable -- :: Permissions -> Bool
- , writable -- :: Permissions -> Bool
- , executable -- :: Permissions -> Bool
- , searchable -- :: Permissions -> Bool
+ Permissions -- instance of (Eq, Ord, Read, Show)
+ ( Permissions
+ , readable -- :: Permissions -> Bool
+ , writable -- :: Permissions -> Bool
+ , executable -- :: Permissions -> Bool
+ , searchable -- :: Permissions -> Bool
+ )
, createDirectory -- :: FilePath -> IO ()
, removeDirectory -- :: FilePath -> IO ()
, getPermissions -- :: FilePath -> IO Permissions
, setPermissions -- :: FilePath -> Permissions -> IO ()
-
-#ifndef __HUGS__
, getModificationTime -- :: FilePath -> IO ClockTime
-#endif
) where
-#ifdef __HUGS__
---import PreludeBuiltin
-#else
-
import Prelude -- Just to get it in the dependencies
-import PrelGHC ( RealWorld, or#, and# )
-import PrelByteArr ( ByteArray, MutableByteArray,
- newWordArray, readWordArray, newCharArray )
-import PrelArrExtra ( unsafeFreezeByteArray )
-import PrelPack ( unpackNBytesST, packString, unpackCStringST )
-import PrelIOBase ( stToIO,
- constructErrorAndFail, constructErrorAndFailWithInfo,
- IOError(IOError), IOErrorType(SystemError) )
import Time ( ClockTime(..) )
-import PrelAddr ( Addr, nullAddr, Word(..), wordToInt, intToWord )
-#endif
+import PrelPosix
+import PrelStorable
+import PrelCString
+import PrelMarshalAlloc
+import PrelCTypesISO
+import PrelCTypes
+import PrelCError
+import PrelPtr
+import PrelIOBase
+import PrelBase
\end{code}
-%*********************************************************
-%* *
-\subsection{Permissions}
-%* *
-%*********************************************************
+-----------------------------------------------------------------------------
+-- 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
} 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
\begin{code}
createDirectory :: FilePath -> IO ()
createDirectory path = do
- rc <- primCreateDirectory (primPackString path)
- if rc == 0 then return () else
- constructErrorAndFailWithInfo "createDirectory" path
+ withCString path $ \s -> do
+ throwErrnoIfMinus1Retry_ "createDirectory" $
+ mkdir s 0o777
\end{code}
@removeDirectory dir@ removes an existing directory {\em dir}. The
\begin{code}
removeDirectory :: FilePath -> IO ()
removeDirectory path = do
- rc <- primRemoveDirectory (primPackString path)
- if rc == 0 then
- return ()
- else
- constructErrorAndFailWithInfo "removeDirectory" path
+ 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
\begin{code}
removeFile :: FilePath -> IO ()
removeFile path = do
- rc <- primRemoveFile (primPackString path)
- if rc == 0 then
- return ()
- else
- constructErrorAndFailWithInfo "removeFile" path
+ 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
\begin{code}
renameDirectory :: FilePath -> FilePath -> IO ()
-renameDirectory opath npath = do
- rc <- primRenameDirectory (primPackString opath) (primPackString npath)
- if rc == 0 then
- return ()
- else
- constructErrorAndFailWithInfo "renameDirectory" ("old: " ++ opath ++ ",new: " ++ npath)
+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
\begin{code}
renameFile :: FilePath -> FilePath -> IO ()
-renameFile opath npath = do
- rc <- primRenameFile (primPackString opath) (primPackString npath)
- if rc == 0 then
- return ()
- else
- constructErrorAndFailWithInfo "renameFile" opath
+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
\begin{code}
getDirectoryContents :: FilePath -> IO [FilePath]
getDirectoryContents path = do
- dir <- primOpenDir (primPackString path)
- if dir == nullAddr
- then constructErrorAndFailWithInfo "getDirectoryContents" path
- else loop dir
+ alloca $ \ ptr_dEnt -> do
+ p <- withCString path $ \s ->
+ throwErrnoIfNullRetry "getDirectoryContents" (opendir s)
+ loop ptr_dEnt p
where
- loop :: Addr -> IO [String]
- loop dir = do
- dirent_ptr <- primReadDir dir
- if dirent_ptr == nullAddr
- then do
- -- readDir__ implicitly performs closedir() when the
- -- end is reached.
- return []
- else do
- str <- primGetDirentDName dirent_ptr
- entry <- primUnpackCString str
- entries <- loop dir
- 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
+ if (dEnt == nullPtr)
+ then return []
+ else do
+ 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,
\begin{code}
getCurrentDirectory :: IO FilePath
getCurrentDirectory = do
- str <- primGetCurrentDirectory
- if str /= nullAddr
- then do
- pwd <- primUnpackCString str
- primFree 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,
\begin{code}
setCurrentDirectory :: FilePath -> IO ()
setCurrentDirectory path = do
- rc <- primSetCurrentDirectory (primPackString path)
- if rc == 0
- then return ()
- else constructErrorAndFailWithInfo "setCurrentDirectory" path
+ withCString path $ \s ->
+ throwErrnoIfMinus1Retry_ "setCurrentDirectory" (chdir s)
+ -- ToDo: add path to error
+
\end{code}
To clarify, @doesDirectoryExist@ returns True if a file system object
doesDirectoryExist :: FilePath -> IO Bool
doesDirectoryExist name =
catch
- (getFileStatus name >>= \ st -> return (isDirectory st))
+ (withFileStatus name $ \st -> isDirectory st)
(\ _ -> return False)
doesFileExist :: FilePath -> IO Bool
doesFileExist name = do
catch
- (getFileStatus name >>= \ st -> return (not (isDirectory st)))
+ (withFileStatus name $ \st -> do b <- isDirectory st; return (not b))
(\ _ -> return False)
-foreign import ccall "libHS_cbits" "const_F_OK" unsafe const_F_OK :: Int
-
-#ifndef __HUGS__
getModificationTime :: FilePath -> IO ClockTime
getModificationTime name =
- getFileStatus name >>= \ st ->
+ withFileStatus name $ \ st ->
modificationTime st
-#endif
getPermissions :: FilePath -> IO Permissions
getPermissions name = do
- st <- getFileStatus name
- let
- fm = fileMode st
- isect v = intersectFileMode v fm == v
-
+ 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,
- writable = 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 name (Permissions r w e s) = do
let
- read = if r then ownerReadMode else emptyFileMode
- write = if w then ownerWriteMode else emptyFileMode
- exec = if e || s then ownerExecuteMode else emptyFileMode
+ 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)
- mode = read `unionFileMode` (write `unionFileMode` exec)
+isRegularFile :: Ptr CStat -> IO Bool
+isRegularFile stat = do
+ mode <- st_mode stat
+ return (s_ISREG mode /= 0)
- rc <- primChmod (primPackString name) mode
- if rc == 0
- then return ()
- else ioError (IOError Nothing SystemError "setPermissions" "insufficient permissions")
-\end{code}
+foreign import ccall "prel_s_ISDIR" unsafe s_ISDIR :: CMode -> Int
+foreign import ccall "prel_s_ISREG" unsafe s_ISREG :: CMode -> Int
-(Sigh)..copied from Posix.Files to avoid dep. on posix library
+emptyCMode :: CMode
+emptyCMode = 0
-\begin{code}
-type FileStatus = PrimByteArray
-
-getFileStatus :: FilePath -> IO FileStatus
-getFileStatus name = do
- bytes <- primNewByteArray sizeof_stat
- rc <- primStat (primPackString name) bytes
- if rc == 0
-#ifdef __HUGS__
- then primUnsafeFreezeByteArray bytes
-#else
- then stToIO (unsafeFreezeByteArray bytes)
-#endif
- else ioError (IOError Nothing SystemError "getFileStatus" "")
-
-#ifndef __HUGS__
-modificationTime :: FileStatus -> IO ClockTime
-modificationTime stat = do
- i1 <- stToIO (newWordArray (0,1))
- setFileMode i1 stat
- secs <- stToIO (readWordArray i1 0)
- return (TOD (toInteger (wordToInt secs)) 0)
+unionCMode :: CMode -> CMode -> CMode
+unionCMode = (+)
-foreign import ccall "libHS_cbits" "set_stat_st_mtime" unsafe
- setFileMode :: PrimMutableByteArray RealWorld -> FileStatus -> IO ()
-#endif
+foreign import ccall "prel_mkdir" unsafe mkdir :: CString -> CInt -> IO CInt
-isDirectory :: FileStatus -> Bool
-isDirectory stat = prim_S_ISDIR (fileMode stat) /= 0
+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
-isRegularFile :: FileStatus -> Bool
-isRegularFile stat = prim_S_ISREG (fileMode stat) /= 0
+foreign import ccall unsafe stat :: CString -> Ptr CStat -> IO CInt
-foreign import ccall "libHS_cbits" "sizeof_stat" unsafe sizeof_stat :: Int
-foreign import ccall "libHS_cbits" "prim_stat" unsafe
- primStat :: PrimByteArray -> PrimMutableByteArray RealWorld -> IO Int
+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 ()
-foreign import ccall "libHS_cbits" "get_stat_st_mode" unsafe fileMode :: FileStatus -> FileMode
-foreign import ccall "libHS_cbits" "prim_S_ISDIR" unsafe prim_S_ISDIR :: FileMode -> Int
-foreign import ccall "libHS_cbits" "prim_S_ISREG" unsafe prim_S_ISREG :: FileMode -> Int
-\end{code}
-\begin{code}
-type FileMode = Word
-
-emptyFileMode :: FileMode
-unionFileMode :: FileMode -> FileMode -> FileMode
-intersectFileMode :: FileMode -> FileMode -> FileMode
-
-foreign import ccall "libHS_cbits" "const_S_IRUSR" unsafe ownerReadMode :: FileMode
-foreign import ccall "libHS_cbits" "const_S_IWUSR" unsafe ownerWriteMode :: FileMode
-foreign import ccall "libHS_cbits" "const_S_IXUSR" unsafe ownerExecuteMode :: FileMode
-
-#ifdef __HUGS__
-emptyFileMode = primIntToWord 0
-unionFileMode = primOrWord
-intersectFileMode = primAndWord
-#else
-emptyFileMode = intToWord 0
-unionFileMode = orWord
-intersectFileMode = andWord
-#endif
+type CDirent = ()
\end{code}
-
-Some defns. to allow us to share code.
-
-\begin{code}
-#ifndef __HUGS__
-
-primPackString :: [Char] -> ByteArray Int
-primPackString = packString
---ToDo: fix.
-primUnpackCString :: Addr -> IO String
-primUnpackCString a = stToIO (unpackCStringST a)
-
-type PrimByteArray = ByteArray Int
-type PrimMutableByteArray s = MutableByteArray RealWorld Int
-type CString = PrimByteArray
-
-orWord, andWord :: Word -> Word -> Word
-orWord (W# x#) (W# y#) = W# (x# `or#` y#)
-andWord (W# x#) (W# y#) = W# (x# `and#` y#)
-
-primNewByteArray :: Int -> IO (PrimMutableByteArray s)
-primNewByteArray sz_in_bytes = stToIO (newCharArray (0,sz_in_bytes))
-#endif
-
-foreign import ccall "libHS_cbits" "createDirectory" unsafe primCreateDirectory :: CString -> IO Int
-foreign import ccall "libHS_cbits" "removeDirectory" unsafe primRemoveDirectory :: CString -> IO Int
-foreign import ccall "libHS_cbits" "removeFile" unsafe primRemoveFile :: CString -> IO Int
-foreign import ccall "libHS_cbits" "renameDirectory" unsafe primRenameDirectory :: CString -> CString -> IO Int
-foreign import ccall "libHS_cbits" "renameFile" unsafe primRenameFile :: CString -> CString -> IO Int
-foreign import ccall "libHS_cbits" "openDir__" unsafe primOpenDir :: CString -> IO Addr
-foreign import ccall "libHS_cbits" "readDir__" unsafe primReadDir :: Addr -> IO Addr
-foreign import ccall "libHS_cbits" "get_dirent_d_name" unsafe primGetDirentDName :: Addr -> IO Addr
-foreign import ccall "libHS_cbits" "setCurrentDirectory" unsafe primSetCurrentDirectory :: CString -> IO Int
-foreign import ccall "libHS_cbits" "getCurrentDirectory" unsafe primGetCurrentDirectory :: IO Addr
-foreign import ccall "libc" "free" unsafe primFree :: Addr -> IO ()
-foreign import ccall "libc" "malloc" unsafe primMalloc :: Word -> IO Addr
-foreign import ccall "libc" "chmod" unsafe primChmod :: CString -> Word -> IO Int
-\end{code}
-
projects / ghc-hetmet.git / blobdiff