X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Flib%2Fstd%2FDirectory.lhs;h=6ca00295fd4fd19f3314e95a96182a5fb4aed1ac;hb=e921b2e307532e0f30eefa88b11a124be592bde4;hp=e3bb80cda0e683fffb8aa42eb04e9abf3a6287ef;hpb=e35015434bcde3d5de46b2f25360e8bae00f158d;p=ghc-hetmet.git diff --git a/ghc/lib/std/Directory.lhs b/ghc/lib/std/Directory.lhs index e3bb80c..6ca0029 100644 --- a/ghc/lib/std/Directory.lhs +++ b/ghc/lib/std/Directory.lhs @@ -1,5 +1,5 @@ % -% (c) The AQUA Project, Glasgow University, 1994-1997 +% (c) The AQUA Project, Glasgow University, 1994-1999 % \section[Directory]{Directory interface} @@ -17,62 +17,59 @@ 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 -#include -#include "cbits/stgio.h" #-} module Directory ( - Permissions(Permissions), - - createDirectory, - removeDirectory, - renameDirectory, - getDirectoryContents, - getCurrentDirectory, - setCurrentDirectory, - - removeFile, - renameFile, - - doesFileExist, - doesDirectoryExist, - getPermissions, - setPermissions, - getModificationTime - ) where + Permissions -- abstract + + , 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 () + + +#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, int2Word#, or#, and# ) +import PrelByteArr ( ByteArray, MutableByteArray, + newWordArray, readWordArray, newCharArray, + unsafeFreezeByteArray + ) +import PrelPack ( unpackNBytesST, packString, unpackCStringST ) +import PrelIOBase ( stToIO, + constructErrorAndFail, constructErrorAndFailWithInfo, + IOError(IOError), IOErrorType(SystemError) ) +import Time ( ClockTime(..) ) +import PrelAddr ( Addr, nullAddr, Word(..), wordToInt ) +#endif +\end{code} %********************************************************* %* * @@ -87,7 +84,7 @@ operations are permissible on a file/directory: \begin{code} data Permissions = Permissions { - readable, writeable, + readable, writable, executable, searchable :: Bool } deriving (Eq, Ord, Read, Show) \end{code} @@ -130,8 +127,9 @@ The path refers to an existing non-directory object. \end{itemize} \begin{code} +createDirectory :: FilePath -> IO () createDirectory path = do - rc <- _ccall_ createDirectory path + rc <- primCreateDirectory (primPackString path) if rc == 0 then return () else constructErrorAndFailWithInfo "createDirectory" path \end{code} @@ -171,8 +169,9 @@ The operand refers to an existing non-directory object. \end{itemize} \begin{code} +removeDirectory :: FilePath -> IO () removeDirectory path = do - rc <- _ccall_ removeDirectory path + rc <- primRemoveDirectory (primPackString path) if rc == 0 then return () else @@ -208,8 +207,9 @@ The operand refers to an existing directory. \end{itemize} \begin{code} +removeFile :: FilePath -> IO () removeFile path = do - rc <- _ccall_ removeFile path + rc <- primRemoveFile (primPackString path) if rc == 0 then return () else @@ -255,12 +255,13 @@ Either path refers to an existing non-directory object. \end{itemize} \begin{code} +renameDirectory :: FilePath -> FilePath -> IO () renameDirectory opath npath = do - rc <- _ccall_ renameDirectory opath npath + rc <- primRenameDirectory (primPackString opath) (primPackString npath) if rc == 0 then return () else - constructErrorAndFailWithInfo "renameDirectory" opath + constructErrorAndFailWithInfo "renameDirectory" ("old: " ++ opath ++ ",new: " ++ npath) \end{code} @renameFile old@ {\em new} changes the name of an existing file system @@ -300,8 +301,9 @@ Either path refers to an existing directory. \end{itemize} \begin{code} +renameFile :: FilePath -> FilePath -> IO () renameFile opath npath = do - rc <- _ccall_ renameFile opath npath + rc <- primRenameFile (primPackString opath) (primPackString npath) if rc == 0 then return () else @@ -334,28 +336,24 @@ 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 - if dir == ``NULL'' + dir <- primOpenDir (primPackString path) + if dir == nullAddr 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'' + dirent_ptr <- primReadDir dir + if dirent_ptr == nullAddr 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) + str <- primGetDirentDName dirent_ptr + entry <- primUnpackCString str entries <- loop dir return (entry:entries) \end{code} @@ -382,13 +380,13 @@ The operating system has no notion of current directory. \end{itemize} \begin{code} +getCurrentDirectory :: IO FilePath getCurrentDirectory = do - str <- _ccall_ getCurrentDirectory - if str /= ``NULL'' + str <- primGetCurrentDirectory + if str /= nullAddr then do - len <- _ccall_ strlen str - pwd <- stToIO (unpackNBytesST str len) - _ccall_ free str + pwd <- primUnpackCString str + primFree str return pwd else constructErrorAndFail "getCurrentDirectory" @@ -421,132 +419,175 @@ The path refers to an existing non-directory object. \end{itemize} \begin{code} +setCurrentDirectory :: FilePath -> IO () setCurrentDirectory path = do - rc <- _ccall_ setCurrentDirectory path + rc <- primSetCurrentDirectory (primPackString path) 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 +doesDirectoryExist :: FilePath -> IO Bool +doesDirectoryExist name = + catch + (getFileStatus name >>= \ st -> return (isDirectory st)) + (\ _ -> return False) + +doesFileExist :: FilePath -> IO Bool doesFileExist name = do - rc <- _ccall_ access name (``F_OK''::Int) - return (rc == 0) + catch + (getFileStatus name >>= \ st -> return (not (isDirectory st))) + (\ _ -> return False) ---doesDirectoryExist :: FilePath -> IO Bool -doesDirectoryExist name = - (getFileStatus name >>= \ st -> return (isDirectory st)) - `catch` - (\ _ -> return False) +foreign import ccall "libHS_cbits.so" "const_F_OK" unsafe const_F_OK :: Int ---getModificationTime :: FilePath -> IO ClockTime +#ifndef __HUGS__ +getModificationTime :: FilePath -> IO ClockTime getModificationTime name = getFileStatus name >>= \ st -> modificationTime st +#endif ---getPermissions :: FilePath -> IO Permissions -getPermissions name = - getFileStatus name >>= \ st -> +getPermissions :: FilePath -> IO Permissions +getPermissions name = do + st <- getFileStatus name let fm = fileMode st isect v = intersectFileMode v fm == v - in + return ( Permissions { readable = isect ownerReadMode, - writeable = isect ownerWriteMode, + writable = isect ownerWriteMode, executable = not (isDirectory st) && isect ownerExecuteMode, searchable = not (isRegularFile st) && isect ownerExecuteMode } - ) + ) ---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 ownerReadMode else emptyFileMode + write = if w then ownerWriteMode else emptyFileMode + exec = if e || s then ownerExecuteMode else emptyFileMode - mode = I# (word2Int# (read# `or#` write# `or#` exec#)) + mode = read `unionFileMode` (write `unionFileMode` exec) - rc <- _ccall_ chmod name mode + rc <- primChmod (primPackString name) mode if rc == 0 then return () - else fail (IOError Nothing SystemError "Directory.setPermissions") - + else ioError (IOError Nothing SystemError "setPermissions" "insufficient permissions") \end{code} - (Sigh)..copied from Posix.Files to avoid dep. on posix library \begin{code} -type FileStatus = ByteArray Int +type FileStatus = PrimByteArray getFileStatus :: FilePath -> IO FileStatus getFileStatus name = do - bytes <- stToIO (newCharArray (0,``sizeof(struct stat)'')) - rc <- _casm_ ``%r = stat(%0,(struct stat *)%1);'' name bytes + bytes <- primNewByteArray sizeof_stat + rc <- primStat (primPackString name) bytes if rc == 0 +#ifdef __HUGS__ + then primUnsafeFreezeByteArray bytes +#else then stToIO (unsafeFreezeByteArray bytes) - else fail (IOError Nothing SystemError "Directory.getFileStatus") +#endif + else ioError (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 - 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#) + i1 <- stToIO (newWordArray (0,1)) + setFileMode i1 stat + secs <- stToIO (readWordArray i1 0) + return (TOD (toInteger (wordToInt secs)) 0) + +foreign import ccall "libHS_cbits.so" "set_stat_st_mtime" unsafe + setFileMode :: PrimMutableByteArray RealWorld -> FileStatus -> IO () +#endif isDirectory :: FileStatus -> Bool -isDirectory stat = unsafePerformIO $ do - rc <- _casm_ ``%r = S_ISDIR(((struct stat *)%0)->st_mode);'' stat - return (rc /= 0) +isDirectory stat = prim_S_ISDIR (fileMode stat) /= 0 isRegularFile :: FileStatus -> Bool -isRegularFile stat = unsafePerformIO $ do - rc <- _casm_ ``%r = S_ISREG(((struct stat *)%0)->st_mode);'' stat - return (rc /= 0) +isRegularFile stat = prim_S_ISREG (fileMode stat) /= 0 + +foreign import ccall "libHS_cbits.so" "sizeof_stat" unsafe sizeof_stat :: Int +foreign import ccall "libHS_cbits.so" "prim_stat" unsafe + primStat :: PrimByteArray -> PrimMutableByteArray RealWorld -> IO Int + +foreign import ccall "libHS_cbits.so" "get_stat_st_mode" unsafe fileMode :: FileStatus -> FileMode +foreign import ccall "libHS_cbits.so" "prim_S_ISDIR" unsafe prim_S_ISDIR :: FileMode -> Int +foreign import ccall "libHS_cbits.so" "prim_S_ISREG" unsafe prim_S_ISREG :: FileMode -> Int \end{code} \begin{code} type FileMode = Word -ownerReadMode :: FileMode -ownerReadMode = ``S_IRUSR'' -ownerWriteMode :: FileMode -ownerWriteMode = ``S_IWUSR'' +emptyFileMode :: FileMode +unionFileMode :: FileMode -> FileMode -> FileMode +intersectFileMode :: FileMode -> FileMode -> FileMode -ownerExecuteMode :: FileMode -ownerExecuteMode = ``S_IXUSR'' +foreign import ccall "libHS_cbits.so" "const_S_IRUSR" unsafe ownerReadMode :: FileMode +foreign import ccall "libHS_cbits.so" "const_S_IWUSR" unsafe ownerWriteMode :: FileMode +foreign import ccall "libHS_cbits.so" "const_S_IXUSR" unsafe ownerExecuteMode :: FileMode + +#ifdef __HUGS__ +emptyFileMode = primIntToWord 0 +unionFileMode = primOrWord +intersectFileMode = primAndWord +#else +--ToDo: tidy up. +emptyFileMode = W# (int2Word# 0#) +unionFileMode = orWord +intersectFileMode = andWord +#endif -intersectFileMode :: FileMode -> FileMode -> FileMode -intersectFileMode (W# m1#) (W# m2#) = W# (m1# `and#` m2#) +\end{code} -fileMode :: FileStatus -> FileMode -fileMode stat = unsafePerformIO ( - _casm_ ``%r = ((struct stat *)%0)->st_mode;'' stat) +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.so" "createDirectory" unsafe primCreateDirectory :: CString -> IO Int +foreign import ccall "libHS_cbits.so" "removeDirectory" unsafe primRemoveDirectory :: CString -> IO Int +foreign import ccall "libHS_cbits.so" "removeFile" unsafe primRemoveFile :: CString -> IO Int +foreign import ccall "libHS_cbits.so" "renameDirectory" unsafe primRenameDirectory :: CString -> CString -> IO Int +foreign import ccall "libHS_cbits.so" "renameFile" unsafe primRenameFile :: CString -> CString -> IO Int +foreign import ccall "libHS_cbits.so" "openDir__" unsafe primOpenDir :: CString -> IO Addr +foreign import ccall "libHS_cbits.so" "readDir__" unsafe primReadDir :: Addr -> IO Addr +foreign import ccall "libHS_cbits.so" "get_dirent_d_name" unsafe primGetDirentDName :: Addr -> IO Addr +foreign import ccall "libHS_cbits.so" "setCurrentDirectory" unsafe primSetCurrentDirectory :: CString -> IO Int +foreign import ccall "libHS_cbits.so" "getCurrentDirectory" unsafe primGetCurrentDirectory :: IO Addr +foreign import ccall "libc.so.6" "free" unsafe primFree :: Addr -> IO () +foreign import ccall "libc.so.6" "malloc" unsafe primMalloc :: Word -> IO Addr +foreign import ccall "libc.so.6" "chmod" unsafe primChmod :: CString -> Word -> IO Int \end{code} +