X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Flib%2Fstd%2FDirectory.lhs;h=84effa4db6725634a2cc28d31dfaddc974358037;hb=239e9471e104fd88ec93bf42623c3a68a496657a;hp=6e77569995b0f91a7f82b676382001759c391316;hpb=7f386840ce17159c13ff452d1099e0cbce7ddb5d;p=ghc-hetmet.git diff --git a/ghc/lib/std/Directory.lhs b/ghc/lib/std/Directory.lhs index 6e77569..84effa4 100644 --- a/ghc/lib/std/Directory.lhs +++ b/ghc/lib/std/Directory.lhs @@ -1,7 +1,8 @@ +% ----------------------------------------------------------------------------- % -% (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 @@ -17,15 +18,16 @@ some operating systems, it may also be possible to have paths which are relative to the current directory. \begin{code} -{-# OPTIONS -#include -#include -#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 () @@ -44,41 +46,31 @@ module Directory , 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 @@ -88,11 +80,8 @@ 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 @@ -128,9 +117,9 @@ The path refers to an existing non-directory object. \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 @@ -170,14 +159,12 @@ The operand refers to an existing non-directory object. \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 @@ -208,14 +195,12 @@ The operand refers to an existing directory. \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 @@ -255,15 +240,21 @@ Either path refers to an existing non-directory object. \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 @@ -301,12 +292,18 @@ Either path refers to an existing directory. \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 @@ -337,24 +334,36 @@ The path refers to an existing non-directory object. \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, @@ -381,14 +390,23 @@ The operating system has no notion of current directory. \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, @@ -420,10 +438,10 @@ The path refers to an existing non-directory object. \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 @@ -435,157 +453,116 @@ file system object that is not a directory.) 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} -