X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Flib%2Fstd%2FDirectory.lhs;h=6ca00295fd4fd19f3314e95a96182a5fb4aed1ac;hb=e921b2e307532e0f30eefa88b11a124be592bde4;hp=b209404e61a21f7408881d6b611046080c0041d8;hpb=438596897ebbe25a07e1c82085cfbc5bdb00f09e;p=ghc-hetmet.git diff --git a/ghc/lib/std/Directory.lhs b/ghc/lib/std/Directory.lhs index b209404..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} @@ -20,82 +20,55 @@ are relative to the current directory. {-# OPTIONS -#include -#include -#include "cbits/stgio.h" #-} module Directory ( - Permissions(Permissions), - - createDirectory, - removeDirectory, - renameDirectory, - getDirectoryContents, - getCurrentDirectory, - setCurrentDirectory, - - removeFile, - renameFile, - - doesFileExist, - doesDirectoryExist, - getPermissions, - setPermissions, -#ifndef __HUGS__ - getModificationTime -#endif - ) where + Permissions -- abstract + + , readable -- :: Permissions -> Bool + , writable -- :: Permissions -> Bool + , executable -- :: Permissions -> Bool + , searchable -- :: Permissions -> Bool -#ifdef __HUGS__ -import PreludeBuiltin -#else -import PrelBase -import PrelIOBase -import PrelHandle -import PrelST -import PrelArr -import PrelPack ( unpackNBytesST ) -import PrelAddr -import Time ( ClockTime(..) ) -#endif + , createDirectory -- :: FilePath -> IO () + , removeDirectory -- :: FilePath -> IO () + , renameDirectory -- :: FilePath -> FilePath -> IO () -\end{code} + , 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 () -%********************************************************* -%* * -\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 + , getModificationTime -- :: FilePath -> IO ClockTime #endif -\end{code} + ) where -\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 +--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} %********************************************************* @@ -111,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} @@ -154,13 +127,9 @@ The path refers to an existing non-directory object. \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} @@ -200,12 +169,9 @@ The operand refers to an existing non-directory object. \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 @@ -241,12 +207,9 @@ The operand refers to an existing directory. \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 @@ -292,12 +255,9 @@ Either path refers to an existing non-directory object. \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 @@ -341,12 +301,9 @@ Either path refers to an existing directory. \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 @@ -379,8 +336,7 @@ The path refers to an existing non-directory object. \end{itemize} \begin{code} ---getDirectoryContents :: FilePath -> IO [FilePath] -#ifdef __HUGS__ +getDirectoryContents :: FilePath -> IO [FilePath] getDirectoryContents path = do dir <- primOpenDir (primPackString path) if dir == nullAddr @@ -400,31 +356,6 @@ getDirectoryContents path = do 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, @@ -449,23 +380,13 @@ The operating system has no notion of current directory. \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" @@ -498,64 +419,58 @@ The path refers to an existing non-directory object. \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 + 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 #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 -> +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 () -#ifdef __HUGS__ +setPermissions :: FilePath -> Permissions -> IO () setPermissions name (Permissions r w e s) = do let read = if r then ownerReadMode else emptyFileMode @@ -567,31 +482,12 @@ setPermissions name (Permissions r w e s) = do 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 ioError (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 @@ -599,101 +495,99 @@ getFileStatus name = do 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 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 - (# 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.so" "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.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 -#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.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 -ownerReadMode :: FileMode -ownerReadMode = ``S_IRUSR'' +--ToDo: tidy up. +emptyFileMode = W# (int2Word# 0#) +unionFileMode = orWord +intersectFileMode = andWord +#endif -ownerWriteMode :: FileMode -ownerWriteMode = ``S_IWUSR'' +\end{code} -ownerExecuteMode :: FileMode -ownerExecuteMode = ``S_IXUSR'' +Some defns. to allow us to share code. -intersectFileMode :: FileMode -> FileMode -> FileMode -intersectFileMode (W# m1#) (W# m2#) = W# (m1# `and#` m2#) +\begin{code} +#ifndef __HUGS__ + +primPackString :: [Char] -> ByteArray Int +primPackString = packString +--ToDo: fix. +primUnpackCString :: Addr -> IO String +primUnpackCString a = stToIO (unpackCStringST a) -fileMode :: FileStatus -> FileMode -fileMode stat = unsafePerformIO ( - _casm_ ``%r = ((struct stat *)%0)->st_mode;'' stat) +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} +