X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Flib%2Fstd%2FDirectory.lhs;h=3d0f848a983619136efa281136e804780f691834;hb=012eb96576a6f5a0427799f489f16927c77747d4;hp=778ecad661a616535b287356703acea56c721bec;hpb=de8e0e31b41f9f60aad330d62d06b6c5c1596d9e;p=ghc-hetmet.git diff --git a/ghc/lib/std/Directory.lhs b/ghc/lib/std/Directory.lhs index 778ecad..3d0f848 100644 --- a/ghc/lib/std/Directory.lhs +++ b/ghc/lib/std/Directory.lhs @@ -1,7 +1,8 @@ +% ----------------------------------------------------------------------------- % -% (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 @@ -17,86 +18,70 @@ some operating systems, it may also be possible to have paths which are relative to the current directory. \begin{code} -{-# OPTIONS -#include -#include #-} +{-# OPTIONS -#include "dirUtils.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 @@ -130,10 +115,11 @@ The path refers to an existing non-directory object. \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 @@ -171,15 +157,14 @@ The operand refers to an existing non-directory object. \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 @@ -208,15 +193,14 @@ The operand refers to an existing directory. \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 @@ -255,15 +239,22 @@ Either path refers to an existing non-directory object. \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 @@ -300,12 +291,19 @@ Either path refers to an existing directory. \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 @@ -334,29 +332,32 @@ The path refers to an existing non-directory object. \end{itemize} \begin{code} ---getDirectoryContents :: FilePath -> IO [FilePath] +getDirectoryContents :: FilePath -> IO [FilePath] getDirectoryContents path = do - dir <- _ccall_ openDir__ path - ptr <- _ccall_ malloc (``sizeof(struct dirent**)''::Int) - if dir == ``NULL'' - then constructErrorAndFail "getDirectoryContents" - else loop dir ptr + p <- withCString path $ \s -> + throwErrnoIfNullRetry "getDirectoryContents" (opendir s) + loop p where - loop :: Addr -> Addr -> IO [String] - loop dir dirent_ptr = do - dirent_ptr <- _ccall_ readDir__ dir - if dirent_ptr == ``NULL'' - then do - 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 dirent_ptr - return (entry:entries) + loop :: Ptr CDir -> IO [String] + loop dir = do + resetErrno + p <- readdir dir + if (p /= nullPtr) + then do + entry <- (d_name p >>= peekCString) + entries <- loop dir + return (entry:entries) + else do errno <- getErrno + if (errno == eINTR) then loop 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, @@ -381,16 +382,25 @@ The operating system has no notion of current directory. \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, @@ -420,132 +430,136 @@ The path refers to an existing non-directory object. \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# } + 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 = I# (word2Int# (read# `or#` write# `or#` exec#)) + mode = read `unionCMode` (write `unionCMode` exec) - rc <- _ccall_ chmod name mode - if rc == 0 - then return () - else fail (IOError Nothing SystemError "Directory.setPermissions") + withCString name $ \s -> + throwErrnoIfMinus1_ "setPermissions" $ chmod s mode -\end{code} +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 -(Sigh)..copied from Posix.Files to avoid dep. on posix library +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 -\begin{code} -type FileStatus = ByteArray Int +foreign import ccall "prel_sz_stat" unsafe sizeof_stat :: 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 "Directory.getFileStatus") - -modificationTime :: FileStatus -> IO ClockTime +modificationTime :: Ptr CStat -> 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'' - -ownerWriteMode :: FileMode -ownerWriteMode = ``S_IWUSR'' - -ownerExecuteMode :: FileMode -ownerExecuteMode = ``S_IXUSR'' - -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) + mtime <- st_mtime stat + return (TOD (toInteger (mtime :: CTime)) 0) + +foreign import ccall "prel_st_mtime" unsafe st_mtime :: Ptr CStat -> IO CTime +foreign import ccall "prel_st_mode" unsafe st_mode :: Ptr CStat -> IO CMode + +isDirectory :: Ptr CStat -> IO Bool +isDirectory stat = do + mode <- st_mode stat + return (s_ISDIR mode /= 0) + +isRegularFile :: Ptr CStat -> IO Bool +isRegularFile stat = do + mode <- st_mode stat + return (s_ISREG mode /= 0) + +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 + +unionCMode :: CMode -> CMode -> CMode +unionCMode = (+) + +foreign import ccall "prel_mkdir" unsafe mkdir :: CString -> CInt -> IO CInt + +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 readdir :: Ptr CDir -> IO (Ptr CDirent) +foreign import ccall unsafe closedir :: Ptr CDir -> IO CInt + +foreign import ccall unsafe stat :: CString -> Ptr CStat -> IO CInt + +foreign import ccall "prel_lstat" unsafe lstat :: CString -> Ptr CStat -> IO CInt + +type CDirent = () \end{code}