1 {-# OPTIONS -fno-implicit-prelude #-}
3 -- ---------------------------------------------------------------------------
4 -- $Id: PrelPosix.hsc,v 1.14 2001/09/26 10:35:41 simonmar Exp $
6 -- POSIX support layer for the standard libraries
8 -- Non-posix compliant in order to support the following features:
9 -- * S_ISSOCK (no sockets in POSIX)
11 module PrelPosix where
13 -- See above comment for non-Posixness reasons.
14 -- #include "PosixSource.h"
30 import PrelMarshalAlloc
31 import PrelMarshalUtils
37 -- ---------------------------------------------------------------------------
43 type CDev = #type dev_t
44 type CIno = #type ino_t
45 type CMode = #type mode_t
46 type COff = #type off_t
47 type CPid = #type pid_t
49 #ifdef mingw32_TARGET_OS
50 type CSsize = #type size_t
52 type CGid = #type gid_t
53 type CNlink = #type nlink_t
54 type CSsize = #type ssize_t
55 type CUid = #type uid_t
57 type CSpeed = #type speed_t
58 type CTcflag = #type tcflag_t
61 -- ---------------------------------------------------------------------------
62 -- stat()-related stuff
66 fdFileSize :: Int -> IO Integer
68 allocaBytes (#const sizeof(struct stat)) $ \ p_stat -> do
69 throwErrnoIfMinus1Retry "fileSize" $
70 c_fstat (fromIntegral fd) p_stat
71 c_mode <- (#peek struct stat, st_mode) p_stat :: IO CMode
72 if not (s_isreg c_mode)
75 c_size <- (#peek struct stat, st_size) p_stat :: IO COff
76 return (fromIntegral c_size)
78 data FDType = Directory | Stream | RegularFile
81 fdType :: Int -> IO FDType
83 allocaBytes (#const sizeof(struct stat)) $ \ p_stat -> do
84 throwErrnoIfMinus1Retry "fileSize" $
85 c_fstat (fromIntegral fd) p_stat
86 c_mode <- (#peek struct stat, st_mode) p_stat :: IO CMode
88 _ | s_isdir c_mode -> return Directory
89 | s_isfifo c_mode || s_issock c_mode -> return Stream
90 | s_isreg c_mode -> return RegularFile
91 | otherwise -> ioException ioe_unknownfiletype
93 ioe_unknownfiletype = IOError Nothing UnsupportedOperation "fdType"
94 "unknown file type" Nothing
96 foreign import "s_isreg_PrelPosix_wrap" unsafe s_isreg :: CMode -> Bool
97 #def inline int s_isreg_PrelPosix_wrap(m) { return S_ISREG(m); }
99 foreign import "s_isdir_PrelPosix_wrap" unsafe s_isdir :: CMode -> Bool
100 #def inline int s_isdir_PrelPosix_wrap(m) { return S_ISDIR(m); }
102 foreign import "s_isfifo_PrelPosix_wrap" unsafe s_isfifo :: CMode -> Bool
103 #def inline int s_isfifo_PrelPosix_wrap(m) { return S_ISFIFO(m); }
105 #ifndef mingw32_TARGET_OS
106 foreign import "s_issock_PrelPosix_wrap" unsafe s_issock :: CMode -> Bool
107 #def inline int s_issock_PrelPosix_wrap(m) { return S_ISSOCK(m); }
109 s_issock :: CMode -> Bool
110 s_issock cmode = False
113 -- It isn't clear whether ftruncate is POSIX or not (I've read several
114 -- manpages and they seem to conflict), so we truncate using open/2.
115 fileTruncate :: FilePath -> IO ()
116 fileTruncate file = do
117 let flags = o_WRONLY .|. o_TRUNC
118 withCString file $ \file_cstr -> do
119 fd <- fromIntegral `liftM`
120 throwErrnoIfMinus1Retry "fileTruncate"
121 (c_open file_cstr (fromIntegral flags) 0o666)
125 -- ---------------------------------------------------------------------------
126 -- Terminal-related stuff
128 fdIsTTY :: Int -> IO Bool
129 fdIsTTY fd = c_isatty (fromIntegral fd) >>= return.toBool
131 #ifndef mingw32_TARGET_OS
135 setEcho :: Int -> Bool -> IO ()
137 allocaBytes (#const sizeof(struct termios)) $ \p_tios -> do
138 throwErrnoIfMinus1Retry "setEcho"
139 (c_tcgetattr (fromIntegral fd) p_tios)
140 c_lflag <- (#peek struct termios, c_lflag) p_tios :: IO CTcflag
141 let new_c_lflag | on = c_lflag .|. (#const ECHO)
142 | otherwise = c_lflag .&. complement (#const ECHO)
143 (#poke struct termios, c_lflag) p_tios (new_c_lflag :: CTcflag)
144 tcSetAttr fd (#const TCSANOW) p_tios
146 getEcho :: Int -> IO Bool
148 allocaBytes (#const sizeof(struct termios)) $ \p_tios -> do
149 throwErrnoIfMinus1Retry "setEcho"
150 (c_tcgetattr (fromIntegral fd) p_tios)
151 c_lflag <- (#peek struct termios, c_lflag) p_tios :: IO CTcflag
152 return ((c_lflag .&. (#const ECHO)) /= 0)
154 setCooked :: Int -> Bool -> IO ()
155 setCooked fd cooked =
156 allocaBytes (#const sizeof(struct termios)) $ \p_tios -> do
157 throwErrnoIfMinus1Retry "setCooked"
158 (c_tcgetattr (fromIntegral fd) p_tios)
160 -- turn on/off ICANON
161 c_lflag <- (#peek struct termios, c_lflag) p_tios :: IO CTcflag
162 let new_c_lflag | cooked = c_lflag .|. (#const ICANON)
163 | otherwise = c_lflag .&. complement (#const ICANON)
164 (#poke struct termios, c_lflag) p_tios (new_c_lflag :: CTcflag)
166 -- set VMIN & VTIME to 1/0 respectively
168 let c_cc = (#ptr struct termios, c_cc) p_tios
169 vmin = c_cc `plusPtr` (#const VMIN) :: Ptr Word8
170 vtime = c_cc `plusPtr` (#const VTIME) :: Ptr Word8
174 tcSetAttr fd (#const TCSANOW) p_tios
176 -- tcsetattr() when invoked by a background process causes the process
177 -- to be sent SIGTTOU regardless of whether the process has TOSTOP set
178 -- in its terminal flags (try it...). This function provides a
179 -- wrapper which temporarily blocks SIGTTOU around the call, making it
182 tcSetAttr :: FD -> CInt -> Ptr Termios -> IO ()
183 tcSetAttr fd options p_tios = do
184 allocaBytes (#const sizeof(sigset_t)) $ \ p_sigset -> do
185 allocaBytes (#const sizeof(sigset_t)) $ \ p_old_sigset -> do
186 c_sigemptyset p_sigset
187 c_sigaddset p_sigset (#const SIGTTOU)
188 c_sigprocmask (#const SIG_BLOCK) p_sigset p_old_sigset
189 throwErrnoIfMinus1Retry_ "tcSetAttr" $
190 c_tcsetattr (fromIntegral fd) options p_tios
191 c_sigprocmask (#const SIG_SETMASK) p_old_sigset nullPtr
195 -- bogus defns for win32
196 setCooked :: Int -> Bool -> IO ()
197 setCooked fd cooked = return ()
199 setEcho :: Int -> Bool -> IO ()
200 setEcho fd on = return ()
202 getEcho :: Int -> IO Bool
203 getEcho fd = return False
207 -- ---------------------------------------------------------------------------
208 -- Turning on non-blocking for a file descriptor
210 #ifndef mingw32_TARGET_OS
212 setNonBlockingFD fd = do
213 flags <- throwErrnoIfMinus1Retry "setNonBlockingFD"
214 (fcntl_read (fromIntegral fd) (#const F_GETFL))
215 -- An error when setting O_NONBLOCK isn't fatal: on some systems
216 -- there are certain file handles on which this will fail (eg. /dev/null
217 -- on FreeBSD) so we throw away the return code from fcntl_write.
218 fcntl_write (fromIntegral fd)
219 (#const F_SETFL) (flags .|. #const O_NONBLOCK)
222 -- bogus defns for win32
223 setNonBlockingFD fd = return ()
227 -- -----------------------------------------------------------------------------
230 foreign import "stat" unsafe
231 c_stat :: CString -> Ptr CStat -> IO CInt
233 foreign import "fstat" unsafe
234 c_fstat :: CInt -> Ptr CStat -> IO CInt
237 foreign import "lstat" unsafe
238 c_lstat :: CString -> Ptr CStat -> IO CInt
241 foreign import "open" unsafe
242 c_open :: CString -> CInt -> CMode -> IO CInt
245 o_RDONLY = (#const O_RDONLY) :: CInt
246 o_WRONLY = (#const O_WRONLY) :: CInt
247 o_RDWR = (#const O_RDWR) :: CInt
248 o_APPEND = (#const O_APPEND) :: CInt
249 o_CREAT = (#const O_CREAT) :: CInt
250 o_EXCL = (#const O_EXCL) :: CInt
251 o_TRUNC = (#const O_TRUNC) :: CInt
253 #ifdef mingw32_TARGET_OS
255 o_NONBLOCK = 0 :: CInt
257 o_NOCTTY = (#const O_NOCTTY) :: CInt
258 o_NONBLOCK = (#const O_NONBLOCK) :: CInt
262 o_BINARY = (#const O_BINARY) :: CInt
265 foreign import "isatty" unsafe
266 c_isatty :: CInt -> IO CInt
268 foreign import "close" unsafe
269 c_close :: CInt -> IO CInt
271 foreign import "lseek" unsafe
272 c_lseek :: CInt -> COff -> CInt -> IO COff
274 foreign import "write" unsafe
275 c_write :: CInt -> Ptr CChar -> CSize -> IO CSsize
277 foreign import "read" unsafe
278 c_read :: CInt -> Ptr CChar -> CSize -> IO CSsize
280 #ifndef mingw32_TARGET_OS
281 foreign import "fcntl" unsafe
282 fcntl_read :: CInt -> CInt -> IO CInt
284 foreign import "fcntl" unsafe
285 fcntl_write :: CInt -> CInt -> CInt -> IO CInt
287 foreign import "fork" unsafe
290 foreign import "sigemptyset_PrelPosix_wrap" unsafe
291 c_sigemptyset :: Ptr CSigset -> IO ()
292 #def inline void sigemptyset_PrelPosix_wrap(sigset_t *set) { sigemptyset(set); }
294 foreign import "sigaddset" unsafe
295 c_sigaddset :: Ptr CSigset -> CInt -> IO ()
297 foreign import "sigprocmask" unsafe
298 c_sigprocmask :: CInt -> Ptr CSigset -> Ptr CSigset -> IO ()
300 foreign import "tcgetattr" unsafe
301 c_tcgetattr :: CInt -> Ptr Termios -> IO CInt
303 foreign import "tcsetattr" unsafe
304 c_tcsetattr :: CInt -> CInt -> Ptr Termios -> IO CInt
306 foreign import "unlink" unsafe
307 c_unlink :: CString -> IO CInt
309 foreign import "waitpid" unsafe
310 c_waitpid :: CPid -> Ptr CInt -> CInt -> IO CPid