+% -----------------------------------------------------------------------------
+% $Id: Directory.lhs,v 1.20 2000/08/24 10:27:01 simonmar Exp $
%
-% (c) The AQUA Project, Glasgow University, 1994-1997
+% (c) The University of Glasgow, 1994-2000
%
+
\section[Directory]{Directory interface}
A directory contains a series of entries, each of which is a named
{-# OPTIONS -#include <sys/stat.h> -#include <dirent.h> -#include "cbits/stgio.h" #-}
module Directory
(
- Permissions(Permissions),
-
- createDirectory,
- removeDirectory,
- renameDirectory,
- getDirectoryContents,
- getCurrentDirectory,
- setCurrentDirectory,
-
- removeFile,
- renameFile,
-
- doesFileExist,
- doesDirectoryExist,
- getPermissions,
- setPermissions,
+ Permissions -- abstract
+
+ , readable -- :: Permissions -> Bool
+ , writable -- :: Permissions -> Bool
+ , executable -- :: Permissions -> Bool
+ , searchable -- :: Permissions -> Bool
+
+ , createDirectory -- :: FilePath -> IO ()
+ , removeDirectory -- :: FilePath -> IO ()
+ , renameDirectory -- :: FilePath -> FilePath -> IO ()
+
+ , getDirectoryContents -- :: FilePath -> IO [FilePath]
+ , getCurrentDirectory -- :: IO FilePath
+ , setCurrentDirectory -- :: FilePath -> IO ()
+
+ , removeFile -- :: FilePath -> IO ()
+ , renameFile -- :: FilePath -> FilePath -> IO ()
+
+ , doesFileExist -- :: FilePath -> IO Bool
+ , doesDirectoryExist -- :: FilePath -> IO Bool
+
+ , getPermissions -- :: FilePath -> IO Permissions
+ , setPermissions -- :: FilePath -> Permissions -> IO ()
+
+
#ifndef __HUGS__
- getModificationTime
+ , getModificationTime -- :: FilePath -> IO ClockTime
#endif
) where
#ifdef __HUGS__
-import PreludeBuiltin
+--import PreludeBuiltin
#else
-import PrelBase
-import PrelIOBase
-import PrelHandle
-import PrelST
-import PrelArr
-import PrelPack ( unpackNBytesST )
-import PrelAddr
-import Time ( ClockTime(..) )
-#endif
-\end{code}
+import Prelude -- Just to get it in the dependencies
-%*********************************************************
-%* *
-\subsection{Signatures}
-%* *
-%*********************************************************
-
-\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 ()
-#ifndef __HUGS__
-getModificationTime :: FilePath -> IO ClockTime
+import PrelGHC ( RealWorld, or#, and# )
+import PrelByteArr ( ByteArray, MutableByteArray,
+ newWordArray, readWordArray, newCharArray )
+import PrelArrExtra ( unsafeFreezeByteArray )
+import PrelPack ( packString, unpackCStringST )
+import PrelIOBase ( stToIO,
+ constructErrorAndFail, constructErrorAndFailWithInfo,
+ IOException(..), ioException, IOErrorType(SystemError) )
+import Time ( ClockTime(..) )
+import PrelAddr ( Addr, nullAddr, Word(..), wordToInt, intToWord )
#endif
-\end{code}
-\begin{code}
-#ifdef __HUGS__
-foreign import stdcall "libHS_cbits.so" "createDirectory" primCreateDirectory :: CString -> IO Int
-foreign import stdcall "libHS_cbits.so" "removeDirectory" primRemoveDirectory :: CString -> IO Int
-foreign import stdcall "libHS_cbits.so" "removeFile" primRemoveFile :: CString -> IO Int
-foreign import stdcall "libHS_cbits.so" "renameDirectory" primRenameDirectory :: CString -> CString -> IO Int
-foreign import stdcall "libHS_cbits.so" "renameFile" primRenameFile :: CString -> CString -> IO Int
-foreign import stdcall "libHS_cbits.so" "openDir__" primOpenDir :: CString -> IO Addr
-foreign import stdcall "libHS_cbits.so" "readDir__" primReadDir :: Addr -> IO Addr
-foreign import stdcall "libHS_cbits.so" "get_dirent_d_name" primGetDirentDName :: Addr -> IO Addr
-foreign import stdcall "libHS_cbits.so" "setCurrentDirectory" primSetCurrentDirectory :: CString -> IO Int
-foreign import stdcall "libHS_cbits.so" "getCurrentDirectory" primGetCurrentDirectory :: IO Addr
-foreign import stdcall "libc.so.6" "free" primFree :: Addr -> IO ()
-foreign import stdcall "libc.so.6" "malloc" primMalloc :: Word -> IO Addr
-foreign import stdcall "libc.so.6" "chmod" primChmod :: CString -> Word -> IO Int
-#endif
\end{code}
%*********************************************************
\begin{code}
data Permissions
= Permissions {
- readable, writeable,
+ readable, writable,
executable, searchable :: Bool
} deriving (Eq, Ord, Read, Show)
\end{code}
\end{itemize}
\begin{code}
-
+createDirectory :: FilePath -> IO ()
createDirectory path = do
-#ifdef __HUGS__
rc <- primCreateDirectory (primPackString path)
-#else
- rc <- _ccall_ createDirectory path
-#endif
if rc == 0 then return () else
constructErrorAndFailWithInfo "createDirectory" path
\end{code}
\end{itemize}
\begin{code}
+removeDirectory :: FilePath -> IO ()
removeDirectory path = do
-#ifdef __HUGS__
rc <- primRemoveDirectory (primPackString path)
-#else
- rc <- _ccall_ removeDirectory path
-#endif
if rc == 0 then
return ()
else
\end{itemize}
\begin{code}
+removeFile :: FilePath -> IO ()
removeFile path = do
-#ifdef __HUGS__
rc <- primRemoveFile (primPackString path)
-#else
- rc <- _ccall_ removeFile path
-#endif
if rc == 0 then
return ()
else
\end{itemize}
\begin{code}
+renameDirectory :: FilePath -> FilePath -> IO ()
renameDirectory opath npath = do
-#ifdef __HUGS__
rc <- primRenameDirectory (primPackString opath) (primPackString npath)
-#else
- rc <- _ccall_ renameDirectory opath npath
-#endif
if rc == 0 then
return ()
else
constructErrorAndFailWithInfo "renameDirectory" ("old: " ++ opath ++ ",new: " ++ npath)
\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 :: FilePath -> FilePath -> IO ()
renameFile opath npath = do
-#ifdef __HUGS__
rc <- primRenameFile (primPackString opath) (primPackString npath)
-#else
- rc <- _ccall_ renameFile opath npath
-#endif
if rc == 0 then
return ()
else
\end{itemize}
\begin{code}
---getDirectoryContents :: FilePath -> IO [FilePath]
-#ifdef __HUGS__
+getDirectoryContents :: FilePath -> IO [FilePath]
getDirectoryContents path = do
dir <- primOpenDir (primPackString path)
if dir == nullAddr
entry <- primUnpackCString str
entries <- loop dir
return (entry:entries)
-#else
-getDirectoryContents path = do
- dir <- _ccall_ openDir__ path
- if dir == ``NULL''
- then constructErrorAndFailWithInfo "getDirectoryContents" path
- else loop dir
- where
- loop :: Addr -> IO [String]
- loop dir = do
- dirent_ptr <- _ccall_ readDir__ dir
- if (dirent_ptr::Addr) == ``NULL''
- then do
- -- readDir__ implicitly performs closedir() when the
- -- end is reached.
- return []
- else do
- str <- _casm_ `` %r=(char*)((struct dirent*)%0)->d_name; '' dirent_ptr
- -- not using the unpackCString function here, since we have to force
- -- the unmarshalling of the directory entry right here as subsequent
- -- calls to readdir() may overwrite it.
- len <- _ccall_ strlen str
- entry <- stToIO (unpackNBytesST str len)
- entries <- loop dir
- return (entry:entries)
-#endif
\end{code}
If the operating system has a notion of current directories,
\end{itemize}
\begin{code}
+getCurrentDirectory :: IO FilePath
getCurrentDirectory = do
-#ifdef __HUGS__
str <- primGetCurrentDirectory
-#else
- str <- _ccall_ getCurrentDirectory
-#endif
if str /= nullAddr
then do
-#ifdef __HUGS__
pwd <- primUnpackCString str
primFree str
-#else
- -- don't use unpackCString (see getDirectoryContents above)
- len <- _ccall_ strlen str
- pwd <- stToIO (unpackNBytesST str len)
- _ccall_ free str
-#endif
return pwd
else
constructErrorAndFail "getCurrentDirectory"
\end{itemize}
\begin{code}
+setCurrentDirectory :: FilePath -> IO ()
setCurrentDirectory path = do
-#ifdef __HUGS__
rc <- primSetCurrentDirectory (primPackString path)
-#else
- rc <- _ccall_ setCurrentDirectory path
-#endif
if rc == 0
then return ()
else constructErrorAndFailWithInfo "setCurrentDirectory" path
\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
-#ifdef __HUGS__
-foreign import stdcall "libc.so.6" "access" primAccess :: PrimByteArray -> Int -> IO Int
-foreign import stdcall "libHS_cbits.so" "const_F_OK" const_F_OK :: Int
+doesDirectoryExist :: FilePath -> IO Bool
+doesDirectoryExist name =
+ catch
+ (getFileStatus name >>= \ st -> return (isDirectory st))
+ (\ _ -> return False)
+doesFileExist :: FilePath -> IO Bool
doesFileExist name = do
- rc <- primAccess (primPackString name) const_F_OK
- return (rc == 0)
-#else
-doesFileExist name = do
- rc <- _ccall_ access name (``F_OK''::Int)
- return (rc == 0)
-#endif
-
---doesDirectoryExist :: FilePath -> IO Bool
-doesDirectoryExist name =
- (getFileStatus name >>= \ st -> return (isDirectory st))
- `catch`
- (\ _ -> return False)
+ catch
+ (getFileStatus name >>= \ st -> return (not (isDirectory st)))
+ (\ _ -> return False)
#ifndef __HUGS__
---getModificationTime :: FilePath -> IO ClockTime
+getModificationTime :: FilePath -> IO ClockTime
getModificationTime name =
getFileStatus name >>= \ st ->
modificationTime st
#endif
---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
+ st <- getFileStatus name
+ read <- primAccess (primPackString name) readOK
+ write <- primAccess (primPackString name) writeOK
+ exec <- primAccess (primPackString name) executeOK
+
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 (isDirectory st) && exec == 0,
+ searchable = not (isRegularFile st) && exec == 0
}
- )
+ )
---setPermissions :: FilePath -> Permissions -> IO ()
-#ifdef __HUGS__
+setPermissions :: FilePath -> Permissions -> IO ()
setPermissions name (Permissions r w e s) = do
let
read = if r then ownerReadMode else emptyFileMode
rc <- primChmod (primPackString name) mode
if rc == 0
then return ()
- else fail (IOError Nothing SystemError "setPermissions" "insufficient permissions")
-#else
-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#))
-
- rc <- _ccall_ chmod name mode
- if rc == 0
- then return ()
- else fail (IOError Nothing SystemError "setPermissions" "insufficient permissions")
-#endif
+ else ioException (IOError Nothing SystemError "setPermissions" "insufficient permissions")
\end{code}
-
(Sigh)..copied from Posix.Files to avoid dep. on posix library
\begin{code}
-#ifdef __HUGS__
-foreign import stdcall "libHS_cbits.so" "sizeof_stat" sizeof_stat :: Int
-foreign import stdcall "libHS_cbits.so" "prim_stat" primStat :: PrimByteArray -> PrimMutableByteArray RealWorld -> IO Int
-
type FileStatus = PrimByteArray
getFileStatus :: FilePath -> IO FileStatus
bytes <- primNewByteArray sizeof_stat
rc <- primStat (primPackString name) bytes
if rc == 0
+#ifdef __HUGS__
then primUnsafeFreezeByteArray bytes
- else fail (IOError Nothing SystemError "getFileStatus" "")
#else
-type FileStatus = ByteArray Int
-
-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 "getFileStatus" "")
+#endif
+ else ioException (IOError Nothing SystemError "getFileStatus" "")
+#ifndef __HUGS__
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
- (# s2#, barr# #) -> (# 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
- (# s2#, r# #) ->
- if r# ==# 0# then
- (# s2#, 0 #)
- else
- case unsafeFreezeByteArray# arr# s2# of
- (# s3#, frozen# #) ->
- (# s3#, J# 1# 1# frozen# #)
-#endif
+ i1 <- stToIO (newWordArray (0,1))
+ setFileMode i1 stat
+ secs <- stToIO (readWordArray i1 0)
+ return (TOD (toInteger (wordToInt secs)) 0)
-#ifdef __HUGS__
-foreign import stdcall "libHS_cbits.so" "get_stat_st_mode" fileMode :: FileStatus -> FileMode
-foreign import stdcall "libHS_cbits.so" "prim_S_ISDIR" prim_S_ISDIR :: FileMode -> Int
-foreign import stdcall "libHS_cbits.so" "prim_S_ISREG" prim_S_ISREG :: FileMode -> Int
+foreign import ccall "libHS_cbits" "set_stat_st_mtime" unsafe
+ setFileMode :: PrimMutableByteArray RealWorld -> FileStatus -> IO ()
+#endif
isDirectory :: FileStatus -> Bool
isDirectory stat = prim_S_ISDIR (fileMode stat) /= 0
isRegularFile :: FileStatus -> Bool
isRegularFile stat = prim_S_ISREG (fileMode stat) /= 0
-#else
-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)
-#endif
+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 "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
-#ifdef __HUGS__
emptyFileMode :: FileMode
unionFileMode :: FileMode -> FileMode -> FileMode
intersectFileMode :: FileMode -> FileMode -> FileMode
-foreign import stdcall "libHS_cbits.so" "const_S_IRUSR" ownerReadMode :: FileMode
-foreign import stdcall "libHS_cbits.so" "const_S_IWUSR" ownerWriteMode :: FileMode
-foreign import stdcall "libHS_cbits.so" "const_S_IXUSR" ownerExecuteMode :: 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
-ownerReadMode :: FileMode
-ownerReadMode = ``S_IRUSR''
+emptyFileMode = intToWord 0
+unionFileMode = orWord
+intersectFileMode = andWord
+#endif
+\end{code}
-ownerWriteMode :: FileMode
-ownerWriteMode = ``S_IWUSR''
+\begin{code}
+type AccessMode = Word
-ownerExecuteMode :: FileMode
-ownerExecuteMode = ``S_IXUSR''
+foreign import ccall "libHS_cbits" "const_R_OK" unsafe readOK :: AccessMode
+foreign import ccall "libHS_cbits" "const_W_OK" unsafe writeOK :: AccessMode
+foreign import ccall "libHS_cbits" "const_X_OK" unsafe executeOK :: AccessMode
+\end{code}
-intersectFileMode :: FileMode -> FileMode -> FileMode
-intersectFileMode (W# m1#) (W# m2#) = W# (m1# `and#` m2#)
+Some defns. to allow us to share code.
-fileMode :: FileStatus -> FileMode
-fileMode stat = unsafePerformIO (
- _casm_ ``%r = ((struct stat *)%0)->st_mode;'' stat)
+\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
+
+foreign import ccall "libc" "access" unsafe
+ primAccess :: CString -> Word -> IO Int
\end{code}
+
projects / ghc-hetmet.git / blobdiff